view release on metacpan or  search on metacpan

lib/AC/MrGamoo/Protocol.pm  view on Meta::CPAN

for my $name (keys %MSGTYPE){
    my $r = $MSGTYPE{$name};
    __PACKAGE__->add_msg( $name, $r->{num}, $r->{reqc}, $r->{resc});
}



sub read_protocol {
    my $io  = shift;
    my $evt = shift;

    $io->{rbuffer} .= $evt->{data};

    return read_http($io, $evt) if $io->{rbuffer} =~ /^GET/;

    my $p = _check_protocol( $io, $evt );
    return unless $p; 	# read more

    # do we have everything?
    return unless length($io->{rbuffer}) >= ($p->{data_length} + $p->{content_length} + $HDRSIZE);

    my $data    = substr($io->{rbuffer}, $HDRSIZE, $p->{data_length});
    my $content = substr($io->{rbuffer}, $HDRSIZE + $p->{data_length}, $p->{content_length});

    # content is passed as reference
    return ($p, $data, ($content ? \$content : undef));
}

sub read_protocol_no_content {
    my $io  = shift;
    my $evt = shift;

    $io->{rbuffer} .= $evt->{data};

    return _read_http($io, $evt) if $io->{rbuffer} =~ /^GET/;

    my $p = _check_protocol( $io, $evt );
    return unless $p; 	# read more

    # do we have everything?
    return unless length($io->{rbuffer}) >= ($p->{data_length} + $HDRSIZE);

    my $data    = substr($io->{rbuffer}, $HDRSIZE, $p->{data_length});
    my $content = substr($io->{rbuffer}, $HDRSIZE + $p->{data_length}, $p->{content_length});

    return ($p, $data, $content);
}

sub _check_protocol {
    my $io  = shift;
    my $evt = shift;

    if( length($io->{rbuffer}) >= $HDRSIZE && !$io->{proto_header} ){
        # decode header
        eval {
            $io->{proto_header} = __PACKAGE__->decode_header( $io->{rbuffer} );
        };
        if(my $e=$@){
            verbose("cannot decode protocol header: $e");
            $io->run_callback('error', {
                cause	=> 'read',
                error	=> "cannot decode protocol: $e",
            });
            $io->shut();
            return;
        }
    }

    return $io->{proto_header};
}

# for simple status queries, argus, debugging
# this is not an RFC compliant http server
sub _read_http {
    my $io  = shift;
    my $evt = shift;

    return unless $io->{rbuffer} =~ /\r?\n\r?\n/s;
    my($get, $url, $http) = $io->{rbuffer} =~ /^(\S+)\s+(\S+)\s+(\S+)/;

    return ( { type => 'http' }, $url );
}


1;