view release on metacpan or  search on metacpan

lib/App/Context/NetServer.pm  view on Meta::CPAN

}

#############################################################################
# PROTECTED METHODS
#############################################################################

=head1 Protected Methods

These methods are considered protected because no class is ever supposed
to call them.  They may however be called by the context-specific drivers.

=cut

#############################################################################
# dispatch_events()
#############################################################################

=head2 dispatch_events()

The dispatch_events() method is called at server startup.
This method is not expected to return control until the server
is exiting.

    * Signature: $context->dispatch_events()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->dispatch_events();

=cut

#  conf_file         "filename"               undef
#
#  log_level         0-4                      2
#  log_file          (filename|Sys::Syslog)   undef
#
#  ## syslog parameters
#  syslog_logsock    (unix|inet)              unix
#  syslog_ident      "identity"               "net_server"
#  syslog_logopt     (cons|ndelay|nowait|pid) pid
#  syslog_facility   \w+                      daemon
#
#  port              \d+                      20203
#  host              "host"                   "*"
#  proto             (tcp|udp|unix)           "tcp"
#  listen            \d+                      SOMAXCONN
#
#  reverse_lookups   1                        undef
#  allow             /regex/                  none
#  deny              /regex/                  none
#
#  ## daemonization parameters
#  pid_file          "filename"               undef
#  chroot            "directory"              undef
#  user              (uid|username)           "nobody"
#  group             (gid|group)              "nobody"
#  background        1                        undef
#  setsid            1                        undef
#
#  no_close_by_child (1|undef)                undef

sub dispatch_events {
    my ($self) = @_;

    my $options = $self->options();
    my @options = qw(
        conf_file
        log_level log_file
        syslog_logsock syslog_ident syslog_logopt syslog_facility
        port host proto listen
        reverse_lookups allow deny
        pid_file chroot user group background setsid
        no_close_by_child
    );

    my (%options);
    #foreach my $option (@options) {
    #    if (defined $options->{"netserver_$option"}) {
    #        $options{$option} = $options->{"netserver_$option"};
    #    }
    #}

    $self->run(%options);  # this initiates the native event loop of Net::Server
    $self->shutdown();
}

#############################################################################
# process_request()
# this is the interface that needs to be implemented for Net::Server
#############################################################################

sub process_request {
    my $self = shift;
    eval {
        local $SIG{ALRM} = sub { die "Timed Out!\n" };
        my $timeout = 10; # give the user 30 seconds to type a line
        #my $header_sent = 0;

        my $previous_alarm = alarm($timeout);
        while (<STDIN>) {
            s/\r?\n$//;
            #if (!$header_sent) {
            #    print "Content-type: text/plain\n\n";
            #    $header_sent = 1;
            #}
            print "You said \"$_\"\r\n";
            alarm($timeout);
        }
        alarm($previous_alarm);
    };
    if( $@=~/timed out/i ){
        print STDOUT "Timed Out.\r\n";
        return;
    }
}

#############################################################################
# send_response()
#############################################################################

=head2 send_response()

    * Signature: $context->send_response()
    * Param:     void
    * Return:    void
    * Throws:    App::Exception
    * Since:     0.01

    Sample Usage: 

    $context->send_response();