File Coverage

blib/lib/Net/Server/Mail.pm
Criterion Covered Total %
statement 179 230 77.8
branch 60 110 54.5
condition 26 59 44.0
subroutine 30 37 81.0
pod 6 28 21.4
total 301 464 64.8


line stmt bran cond sub pod time code
1             package Net::Server::Mail;
2              
3 4     4   55 use 5.006;
  4         12  
4 4     4   16 use strict;
  4         5  
  4         60  
5 4     4   13 use warnings;
  4         5  
  4         110  
6 4     4   1424 use Sys::Hostname;
  4         3453  
  4         169  
7 4     4   1460 use IO::Select;
  4         5221  
  4         156  
8 4     4   23 use IO::Handle;
  4         6  
  4         124  
9 4     4   20 use Carp;
  4         10  
  4         165  
10 4     4   19 use Errno;
  4         12  
  4         122  
11              
12 4     4   16 use constant HOSTNAME => hostname();
  4         7  
  4         9  
13              
14             $Net::Server::Mail::VERSION = '0.28';
15              
16             =pod
17              
18             =head1 NAME
19              
20             Net::Server::Mail - Class to easily create a mail server
21              
22             =head1 SYNOPSIS
23              
24             use Net::Server::Mail::SMTP;
25              
26             my @local_domains = qw(example.com example.org);
27             my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 );
28            
29             my $conn;
30             while($conn = $server->accept)
31             {
32             my $smtp = Net::Server::Mail::SMTP->new( socket => $conn );
33             $smtp->set_callback(RCPT => \&validate_recipient);
34             $smtp->set_callback(DATA => \&queue_message);
35             $smtp->process();
36             $conn->close();
37             }
38              
39             sub validate_recipient
40             {
41             my($session, $recipient) = @_;
42            
43             my $domain;
44             if($recipient =~ /\@(.*)>\s*$/)
45             {
46             $domain = $1;
47             }
48              
49             if(not defined $domain)
50             {
51             return(0, 513, 'Syntax error.');
52             }
53             elsif(not(grep $domain eq $_, @local_domains))
54             {
55             return(0, 554, "$recipient: Recipient address rejected: Relay access denied");
56             }
57              
58             return(1);
59             }
60              
61             sub queue_message
62             {
63             my($session, $data) = @_;
64              
65             my $sender = $session->get_sender();
66             my @recipients = $session->get_recipients();
67              
68             return(0, 554, 'Error: no valid recipients')
69             unless(@recipients);
70            
71             my $msgid = add_queue($sender, \@recipients, $data)
72             or return(0);
73              
74             return(1, 250, "message queued $msgid");
75             }
76              
77             =head1 DESCRIPTION
78              
79             This module is a versatile and extensible implementation of the SMTP
80             protocol and its different evolutions like ESMTP and LMTP. The event
81             driven object-oriented API makes easy to incorporate the SMTP protocol
82             to your programs.
83              
84             Other SMTPd implementations don't support useful ESMTP extensions and
85             the LMTP protocol. Their interface design precludes adding them
86             later. So I've decided to rewrite a complete implementation with
87             extensibility in mind.
88              
89             It provides mechanism to easy addition future or not yet implemented
90             ESMTP extensions. Developers can hook code at each SMTP session state
91             and change the module's behaviors by registering event call-backs. The
92             class is designed to be easily inherited from.
93              
94             This class is the base class for mail service protocols such as
95             B, B and
96             B. Refer to the documentation provided with
97             each of these modules.
98              
99             =head1 METHODS
100              
101             =head2 new
102              
103             $instance = Net::Server::Mail->new( [option => 'value', ...] )
104              
105             options:
106              
107             =over 4
108              
109             =item handle_in
110              
111             Sets the input handle, from which the server reads data. Defaults to
112             STDIN.
113              
114             =item handle_out
115              
116             Sets the output handle, to which the server writes data. Defaults to
117             STDOUT.
118              
119             =item socket
120              
121             Sets a socket to be used for server reads and writes instead of
122             handles.
123              
124             =item error_sleep_time
125              
126             Number of seconds to wait for before printing an error message. This
127             avoids some DoS attacks that attempt to flood the server with bogus
128             commands. A value of 0 turns this feature off. Defaults to 0.
129              
130             =item idle_timeout
131              
132             Number of seconds a connection must remain idle before it is closed.
133             A value of 0 turns this feature off. Defaults to 0.
134              
135             =back
136              
137             =cut
138              
139             sub new {
140 7     7 1 1009440 my ( $proto, @args ) = @_;
141 7   33     64 my $class = ref $proto || $proto;
142 7         24 my $self = {};
143 7         15 bless( $self, $class );
144 7         60 return $self->init(@args);
145             }
146              
147             sub init {
148 7     7 0 22 my $self = shift;
149 7 50       28 confess("odd number of arguments") if ( @_ % 2 );
150             my $options = $self->{options} = {
151 7         71 handle_in => undef,
152             handle_out => undef,
153             socket => undef,
154             error_sleep_time => 0,
155             idle_timeout => 0,
156             };
157 7         37 for ( my $i = 0 ; $i < @_ ; $i += 2 ) {
158 21         67 $options->{ lc( $_[$i] ) } = $_[ $i + 1 ];
159             }
160              
161 7 50 33     47 if ( defined $options->{handle_in} && defined $options->{handle_out} ) {
    50          
162 0 0       0 if ( UNIVERSAL::isa( $options->{handle_in}, 'IO::Handle' ) ) {
163 0         0 $self->{in} = $options->{handle_in};
164             }
165             else {
166             $self->{in} =
167 0         0 IO::Handle->new->fdopen( fileno( $options->{handle_in} ), "r" );
168             }
169 0 0       0 if ( UNIVERSAL::isa( $options->{handle_out}, 'IO::Handle' ) ) {
170 0         0 $self->{out} = $options->{handle_out};
171             }
172             else {
173             $self->{out} =
174 0         0 IO::Handle->new->fdopen( fileno( $options->{handle_out} ), "w" );
175             }
176             }
177             elsif ( defined $options->{'socket'} ) {
178 7         20 $self->{in} = $options->{'socket'};
179 7         28 $self->{out} = $options->{'socket'};
180             }
181             else {
182 0         0 $self->{in} = IO::Handle->new->fdopen( fileno(STDIN), "r" );
183 0         0 $self->{out} = IO::Handle->new->fdopen( fileno(STDOUT), "w" );
184             }
185              
186 7         32 $self->{out}->autoflush(1);
187 7         241 $self->{process_operation} = \&process_operation;
188              
189 7         21 return $self;
190             }
191              
192             =pod
193              
194             =head2 dojob
195              
196             Some commands need to do a job after the handler call. The handler
197             may want to override this to prevent the job from being executed.
198              
199             By calling this method with a (defined) false value as an argument,
200             the expected job isn't executed. Defaults to true.
201              
202             =cut
203              
204 33     33 0 53 sub init_dojob { shift->{_dojob} = 1; }
205              
206             sub dojob {
207 33     33 1 54 my ( $self, $bool ) = @_;
208 33 50       55 $self->{_dojob} = $bool if ( defined $bool );
209 33         83 return $self->{_dojob};
210             }
211              
212             sub make_event {
213 33     33 0 52 my $self = shift;
214 33 50       84 confess('odd number of arguments') if ( @_ % 2 );
215 33         187 my %args = @_;
216              
217 33   33     86 my $name = $args{'name'} || confess('missing argument: \'name\'');
218             my $args = defined $args{'arguments'}
219 33 100 66     123 && ref $args{'arguments'} eq 'ARRAY' ? $args{'arguments'} : [];
220              
221 33         78 $self->init_dojob();
222 33         52 my ( $success, $code, $msg ) = $self->callback( $name, @{$args} );
  33         69  
223              
224             # we have to take a proper decision if successness is undefined
225 33 50       62 if ( not defined $success ) {
226 0 0       0 if ( exists $args{'default_reply'} ) {
227 0 0       0 if ( ref $args{'default_reply'} eq 'ARRAY' ) {
228 0         0 ( $success, $code, $msg ) = $args{'default_reply'};
229 0 0       0 $success = 0 unless defined $success;
230             }
231             else {
232 0         0 $success = $args{'default_reply'};
233             }
234             }
235             else {
236 0         0 $success = 1; # default
237             }
238             }
239              
240             # command may have some job to do regarding to the result. handler
241             # can avoid it by calling dojob() method with a false value.
242 33 50       71 if ( $self->dojob() ) {
243 33 50       55 if ($success) {
244 33 100 66     110 if ( defined $args{'on_success'}
245             and ref $args{'on_success'} eq 'CODE' )
246             {
247 19         25 &{ $args{'on_success'} };
  19         48  
248             }
249             }
250             else {
251 0 0 0     0 if ( defined $args{'on_failure'}
252             and ref $args{'on_failure'} eq 'CODE' )
253             {
254 0         0 &{ $args{'on_failure'} };
  0         0  
255             }
256             }
257             }
258              
259             # ensure that a reply is sent, all SMTP command need at most 1 reply.
260             # some events such as 'stop_session' don't require sending reply.
261 33 100 66     81 unless ( defined $code && !$args{'no_reply'} ) {
262 31 50 33     113 if ( defined $success && $success ) {
263             ( $code, $msg ) =
264 31         63 $self->get_default_reply( $args{'success_reply'}, 250 );
265             }
266             else {
267             ( $code, $msg ) =
268 0         0 $self->get_default_reply( $args{'failure_reply'}, 550 );
269             }
270             }
271              
272 33 50 33     155 die "return code `$code' isn't numeric"
273             if ( defined $code && $code =~ /\D/ );
274              
275 33 100 66     177 $self->handle_reply( $name, $success, $code, $msg )
276             if defined $code and length $code;
277              
278 33         1225 return $success;
279             }
280              
281             sub get_default_reply {
282 31     31 0 58 my ( $self, $config, $default ) = @_;
283              
284 31         52 my ( $code, $msg );
285 31 100       46 if ( defined $config ) {
286 30 100       64 if ( ref $config eq 'ARRAY' ) {
    50          
287 28         52 ( $code, $msg ) = @$config;
288             }
289             elsif ( not ref $config ) {
290 2         3 $code = $config;
291             }
292             else {
293 0         0 confess("unexpected format for reply");
294             }
295             }
296             else {
297 1         2 $code = $default;
298             }
299              
300 31         63 return ( $code, $msg );
301             }
302              
303             sub handle_reply {
304 0     0 0 0 my ( $self, $verb, $success, $code, $msg ) = @_;
305              
306             # don't reply anything if code is empty
307 0 0       0 $self->reply( $code, $msg ) if ( length $code );
308             }
309              
310             sub callback {
311 33     33 0 79 my ( $self, $name, @args ) = @_;
312              
313 33 100       83 if ( defined $self->{callback}->{$name} ) {
314 2         4 my @rv;
315 2         5 eval {
316 2         3 my ( $code, $context ) = @{ $self->{callback}->{$name} };
  2         6  
317 2         23 $self->set_context($context);
318 2         4 @rv = &{$code}( $self, @args );
  2         10  
319             };
320 2 50       1392 if ($@) {
321 0         0 confess $@;
322             }
323 2         9 return @rv;
324             }
325              
326 31         69 return 1;
327             }
328              
329             sub set_context {
330 2     2 0 5 my ( $self, $context ) = @_;
331 2         11 $self->{_context} = $context;
332             }
333              
334             sub get_context {
335 0     0 0 0 my ($self) = @_;
336 0         0 return $self->{_context};
337             }
338              
339             =pod
340              
341             =head2 set_callback
342              
343             ($success, $code, $msg) = $obj->set_callback(VERB, \&function, $context)>
344              
345             Sets the callback code to be called on a particular event. The function should
346             return 1 to 3 values: (success, [return_code, ["message"]]).
347              
348             $mailserver->set_callback
349             (
350             'RCPT', sub
351             {
352             my($address) = @_;
353             if(is_relayed($address))
354             {
355             # default success code/message will be used
356             return 1;
357             }
358             else
359             {
360             return(0, 513, 'Relaying denied.');
361             }
362             }
363             );
364              
365             =cut
366              
367             sub set_callback {
368 7     7 1 90 my ( $self, $name, $code, $context ) = @_;
369 7 50 33     33 confess('bad callback() invocation')
370             unless defined $code && ref $code eq 'CODE';
371 7         26 $self->{callback}->{$name} = [ $code, $context ];
372             }
373              
374             sub def_verb {
375 112     112 0 214 my ( $self, $verb, $coderef ) = @_;
376 112         333 $self->{verb}->{ uc $verb } = $coderef;
377             }
378              
379             sub undef_verb {
380 0     0 0 0 my ( $self, $verb ) = @_;
381             delete $self->{verb}->{$verb}
382 0 0       0 if defined $self->{verb};
383             }
384              
385             sub list_verb {
386 0     0 0 0 my ($self) = @_;
387 0         0 return keys %{ $self->{verb} };
  0         0  
388             }
389              
390             sub next_input_to {
391 35     35 0 68 my ( $self, $method_ref ) = @_;
392 35 100       66 $self->{next_input} = $method_ref
393             if ( defined $method_ref );
394 35         96 return $self->{next_input};
395             }
396              
397             sub tell_next_input_method {
398              
399 4     4 0 8 my ( $self, $input ) = @_;
400              
401             # calling the method and reinitialize. Note: we have to reinit
402             # before calling the code, because code can resetup this variable.
403 4         11 my $code = $self->{next_input};
404 4         8 undef $self->{next_input};
405 4         7 my $rv = &{$code}( $self, $input );
  4         27  
406 4         8 return $rv;
407             }
408              
409             =pod
410              
411             =head2 process
412              
413             $mailserver->process;
414              
415             Start a new session.
416              
417             =cut
418              
419             sub process {
420 7     7 1 30 my ($self) = @_;
421              
422 7         12 my $in = $self->{in};
423 7         22 my $sel = IO::Select->new;
424 7         69 $sel->add($in);
425              
426 7         251 $self->banner;
427              
428             # switch to non-blocking socket to handle PIPELINING
429             # ESMTP extension. See RFC 2920 for more details.
430 7 50       37 if ( $^O eq 'MSWin32' ) {
431              
432             # win32 platforms don't support nonblocking IO
433 0         0 ioctl( $in, 2147772030, 1 );
434             }
435             else {
436 7 50       60 defined( $in->blocking(0) ) or die "Couldn't set nonblocking: $^E";
437             }
438              
439 7         116 my $buffer = "";
440 7         13 while (1) {
441              
442             # wait for data and read it
443 32         48 my $rv = undef;
444              
445 32 50 50     143 if ( $sel->can_read( $self->{options}->{idle_timeout} || undef ) ) {
446 32 50       430676 if ( $^O eq 'MSWin32' ) {
447              
448             # see how much data is available to read
449 0         0 my $size = pack( "L", 0 );
450 0         0 ioctl( $in, 1074030207, $size );
451 0         0 $size = unpack( "L", $size );
452              
453             # read the data to $buffer
454 0         0 $rv = sysread( $in, $buffer, $size, length($buffer) );
455             }
456             else {
457 32         337 $rv = sysread( $in, $buffer, 512 * 1024, length($buffer) );
458             }
459             }
460             else {
461             # timeout
462 0         0 return $self->timeout;
463             }
464              
465             # No data available at the moment
466             next
467             if ( not defined $rv
468 32 0 0     899 and ( $! =~ /Resource temporarily unavailable/ or $!{'EAGAIN'} ) );
      33        
469 32 100 66     204 if ( ( not defined $rv ) or ( $rv == 0 ) ) {
470              
471             # read error or connection closed
472 1 50       27 return $self->stop_session( ( not defined $rv ) ? ($!) : () );
473             }
474              
475             # process all terminated lines
476             # Note: Should accept only CRLF according to RFC. We accept
477             # plain LFs anyway because its more liberal and works as well.
478 31         68 my $newline_idx = rindex( $buffer, "\n" );
479 31 50       60 if ( $newline_idx >= 0 ) {
480              
481             # one or more lines, terminated with \r?\n
482 31         87 my $chunk = substr( $buffer, 0, $newline_idx + 1 );
483              
484             # remaining buffer
485 31         64 $buffer = substr( $buffer, $newline_idx + 1 );
486              
487 31         46 my $rv;
488 31 100       118 if ( defined $self->next_input_to() ) {
489 4         18 $rv = $self->tell_next_input_method($chunk);
490             }
491             else {
492 27         77 $rv = $self->{process_operation}( $self, $chunk );
493             }
494              
495             # if $rv is defined, we have to close the connection
496 31 100       90 if ( defined $rv ) {
497 6         28 return $rv;
498             }
499             }
500              
501             # limit the size of lines to protect from excessive memory consumption
502             # (RFC specifies 1000 bytes including \r\n)
503 25 50       58 if ( length($buffer) > 1000 ) {
504 0         0 $self->make_event(
505             name => 'linetobig',
506             success_reply => [ 552, 'line too long' ]
507             );
508 0         0 return 1;
509             }
510             }
511              
512 0         0 return 1;
513             }
514              
515             sub process_once {
516 0     0 0 0 my ( $self, $operation ) = @_;
517 0 0       0 if ( $self->next_input_to() ) {
518 0         0 return $self->tell_next_input_method($operation);
519             }
520             else {
521 0         0 return $self->{process_operation}( $self, $operation );
522             }
523             }
524              
525             sub process_operation {
526 27     27 0 51 my ( $self, $operation ) = @_;
527 27         77 my ( $verb, $params ) = $self->tokenize_command($operation);
528 27 50 66     112 if ( defined $params && $params =~ /[\r\n]/ ) {
529              
530             # doesn't support grouping of operations
531 0         0 $self->reply( 453,
532             "Command received prior to completion of"
533             . " previous command sequence" );
534 0         0 return;
535             }
536 27         88 $self->process_command( $verb, $params );
537             }
538              
539             sub process_command {
540 27     27 0 53 my ( $self, $verb, $params ) = @_;
541              
542 27 50 33     133 if ( defined $verb && exists $self->{verb}->{$verb} ) {
543 27         51 my $action = $self->{verb}->{$verb};
544 27         31 my $rv;
545 27 100       68 if ( ref $action eq 'CODE' ) {
546 6         11 $rv = &{ $self->{verb}->{$verb} }( $self, $params );
  6         33  
547             }
548             else {
549 21         186 $rv = $self->$action($params);
550             }
551 27         79 return $rv;
552             }
553             else {
554 0         0 $self->reply( 500, 'Syntax error: unrecognized command' );
555 0         0 return;
556             }
557             }
558              
559             sub tokenize_command {
560 27     27 0 61 my ( $self, $line ) = @_;
561 27         205 $line =~ s/\r?\n$//s;
562 27         125 $line =~ s/^\s+|\s+$//g;
563 27         89 my ( $verb, $params ) = split ' ', $line, 2;
564 27 50       83 $verb = uc($verb) if defined($verb);
565 27         78 return ( $verb, $params );
566             }
567              
568             sub reply {
569 39     39 0 113 my ( $self, $code, $msg ) = @_;
570 39         69 my $out = $self->{out};
571              
572             # tempo on error
573             sleep $self->{options}->{error_sleep_time}
574 39 50 66     108 if ( $code >= 400 && $self->{options}->{error_sleep_time} );
575              
576             # default message
577 39 50       79 $msg = $code >= 400 ? 'Failure' : 'Ok'
    100          
578             unless defined $msg;
579              
580             # handle multiple lines
581 39         53 my @lines;
582              
583 39 100       64 if ( ref $msg ) {
584 9 50       23 confess "bad argument" unless ref $msg eq 'ARRAY';
585 9         19 @lines = @$msg;
586             }
587             else {
588 30         103 @lines = split( /\r?\n/, $msg );
589             }
590 39         98 for ( my $i = 0 ; $i < @lines ; $i++ ) {
591              
592             # RFC says that all lines but the last must
593             # split the code and the message with a dash (-)
594 48 100       322 my $sep = $i == $#lines ? ' ' : '-';
595 48         1809 print $out "$code$sep$lines[$i]\r\n";
596             }
597             }
598              
599             sub get_hostname {
600 20     20 0 38 my ($self) = @_;
601 20         83 return HOSTNAME;
602             }
603              
604             sub get_protoname {
605 0     0 0 0 my ($self) = @_;
606 0         0 return 'NOPROTO';
607             }
608              
609             sub get_appname {
610 7     7 0 14 my ($self) = @_;
611 7         17 return 'Net::Server::Mail (Perl)';
612             }
613              
614             ###########################################################
615              
616             =pod
617              
618             =head2 banner
619              
620             Send the introduction banner. You have to call it manually when are
621             using process_once() method. Don't use it with process() method.
622              
623             =head1 EVENTS
624              
625             =head2 banner
626              
627             Append at the opening of a new connection.
628              
629             Handler takes no argument.
630              
631             =cut
632              
633             sub banner {
634 7     7 1 16 my ($self) = @_;
635              
636 7 50       19 unless ( defined $self->{banner_string} ) {
637 7   50     36 my $hostname = $self->get_hostname || '';
638 7   50     23 my $protoname = $self->get_protoname || '';
639 7   50     27 my $appname = $self->get_appname || '';
640              
641 7         10 my $str;
642 7 50       22 $str = $hostname . ' ' if length $hostname;
643 7 50       24 $str .= $protoname . ' ' if length $protoname;
644 7 50       17 $str .= $appname . ' ' if length $appname;
645 7         13 $str .= 'Service ready';
646 7         17 $self->{banner_string} = $str;
647             }
648              
649             $self->make_event(
650             name => 'banner',
651 7         51 success_reply => [ 220, $self->{banner_string} ],
652             failure_reply => [ '', '' ],
653             );
654             }
655              
656             =pod
657              
658             =head2 timeout
659              
660             This event append where timeout is exceeded.
661              
662             Handler takes no argument.
663              
664             =cut
665              
666             sub timeout {
667 0     0 1 0 my ($self) = @_;
668              
669 0         0 $self->make_event(
670             name => 'timeout',
671             success_reply => [
672             421,
673             $self->get_hostname
674             . ' Timeout exceeded, closing transmission channel'
675             ],
676             );
677              
678 0         0 return 1;
679             }
680              
681             =pod
682              
683             =head2 timeout
684              
685             This event append where connection is closed or an error occurs during reading from socket.
686              
687             Takes the error description as an argument if an error occurred and the argument is undefined if the session was closed by peer.
688              
689             $mailserver->set_callback
690             (
691             'stop_session', sub
692             {
693             my($session, $err) = @_;
694             if( defined $err )
695             {
696             print "Error occurred during processing: $err\n";
697             }
698             else
699             {
700             print "Session closed py peer\n";
701             }
702             return 1;
703             }
704             );
705              
706             =cut
707              
708             sub stop_session {
709 1     1 0 4 my ( $self, $err ) = @_;
710              
711 1         7 $self->make_event(
712             name => 'stop_session',
713             arguments => [$err],
714             no_reply => 1,
715             );
716              
717 1         5 return 1;
718             }
719              
720             =pod
721              
722             =head1 SEE ALSO
723              
724             Please, see L, L
725             and L.
726              
727             =head1 AUTHOR
728              
729             Olivier Poitrey Ers@rhapsodyk.netE
730              
731             =head1 AVAILABILITY
732              
733             Available on CPAN.
734              
735             anonymous Git repository:
736              
737             git clone git://github.com/rs/net-server-mail.git
738              
739             Git repository on the web:
740              
741             L
742              
743             =head1 BUGS
744              
745             Please use CPAN system to report a bug (http://rt.cpan.org/).
746              
747             =head1 LICENCE
748              
749             This library is free software; you can redistribute it and/or modify
750             it under the terms of the GNU Lesser General Public License as
751             published by the Free Software Foundation; either version 2.1 of the
752             License, or (at your option) any later version.
753              
754             This library is distributed in the hope that it will be useful, but
755             WITHOUT ANY WARRANTY; without even the implied warranty of
756             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
757             Lesser General Public License for more details.
758              
759             You should have received a copy of the GNU Lesser General Public
760             License along with this library; if not, write to the Free Software
761             Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
762             USA
763              
764             =head1 COPYRIGHT
765              
766             =over
767              
768             =item Copyright (C) 2002 - Olivier Poitrey
769              
770             =item Copyright (C) 2007-2013 - Xavier Guimard
771              
772             =back
773              
774             =head2 STARTTLS
775              
776             =over
777              
778             =item Copyright (C) 2009 - Dan Moore
779              
780             =item Copyright (C) 2013 - Mytram
781              
782             =item Copyright (C) 2013 - Xavier Guimard
783              
784             =back
785              
786             =head2 Contributors
787              
788             =over
789              
790             =item 2012 - Georg Hoesch (patch to reduce memory consumption)
791              
792             =back
793              
794             =cut
795              
796             1;