1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
package Spline::Socketmap;
use strict;
use warnings;
use Scalar::Util qw( openhandle );
use base qw( Exporter Net::Server::PreFork );
our @EXPORT = qw( );
our @EXPORT_OK = qw(
lookup
handle_request
netstring_read
netstring_write
process_request
socketmap_protocol
);
sub lookup($$$) {
die 'Not implemented';
}
sub handle_request($$) {
my $self = shift;
my $data = shift;
my ($map, $key) = split(/ /, $data, 2);
return $self->lookup($map, $key);
}
sub netstring_read_length($) {
my $fd = shift;
my $length;
local $/ = ':';
$length = <$fd>;
die 'Cannot read netstring length' unless defined($length);
chomp $length;
die 'Invalid length' unless $length =~ m/\A\d+\z/;
return $length;
}
sub netstring_read($) {
my $fd = shift;
my ($length, $data);
die 'Filehandle required' unless openhandle($fd);
$length = netstring_read_length($fd);
if (read($fd, $data, $length) == $length) {
my $char = getc($fd);
die "Closing , missing" if not defined $char or $char ne ',';
}
else {
die 'Received only ' . length($data) . " of $length bytes";
}
return $data;
}
sub netstring_write($$) {
my ($fd, $data) = @_;
print $fd length($data).':'.$data.',';
}
sub socketmap_protocol($$) {
my $self = shift;
my $input = shift;
my $result;
eval {
local $SIG{'ALRM'} = sub { die "Timed Out!\n" };
alarm($self->{server}->{timeout} // 0);
if (ref($input) eq 'CODE') {
$input = &$input;
}
$result = $self->handle_request($input);
alarm(0);
};
my $err = $@;
alarm(0);
if ($err) {
if ($err =~ /timed out/i) {
return 'TEMP Timeout';
}
else {
chomp $err;
return "TEMP $err";
}
}
else {
return $result;
}
}
sub recv($) {
my $self = shift;
my $input = netstring_read(*STDIN);
$self->log(3, $input);
return $input;
}
sub send($$) {
my $self = shift;
my ($data) = @_;
$self->log(2, $data);
netstring_write(*STDOUT, $data);
}
sub process_request($) {
my $self = shift;
my $recv = sub { return $self->recv() };
$self->send($self->socketmap_protocol($recv) // 'TEMP Protocol error');
}
sub options($$) {
my $self = shift;
my $prop = $self->{'server'};
my $template = shift;
$self->SUPER::options($template);
# Timeout for one request
$prop->{'timeout'} ||= undef;
$template->{'timeout'} = \$prop->{'timeout'};
}
sub post_configure_hook {
my $self = shift;
my $prop = $self->{'server'};
if (!defined($prop->{'timeout'}) || $prop->{'timeout'} !~ /^\d+$/) {
$prop->{'timeout'} = 10;
}
elsif ($prop->{'timeout'} < 0) {
$prop->{'timeout'} = 0;
}
}
1;
# vim: set et ts=4:
|
