line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::PSYC; |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# ___ __ _ _ __ |
4
|
|
|
|
|
|
|
# | \ (__ \ / / |
5
|
|
|
|
|
|
|
# |__/ \ V | |
6
|
|
|
|
|
|
|
# | (__/ | \__ |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# Protocol for SYnchronous Conferencing. |
9
|
|
|
|
|
|
|
# Official API Implementation in PERL. |
10
|
|
|
|
|
|
|
# See http://psyc.pages.de for further information. |
11
|
|
|
|
|
|
|
# |
12
|
|
|
|
|
|
|
# Copyright (c) 1998-2005 Carlo v. Loesch and Arne Goedeke. |
13
|
|
|
|
|
|
|
# All rights reserved. |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# This program is free software; you may redistribute it and/or modify it |
16
|
|
|
|
|
|
|
# under the same terms as Perl itself. Derivatives may not carry the |
17
|
|
|
|
|
|
|
# title "Official PSYC API Implementation" or equivalents. |
18
|
|
|
|
|
|
|
# |
19
|
|
|
|
|
|
|
# Concerning UDP: No retransmissions or other safety strategies are |
20
|
|
|
|
|
|
|
# implemented - and none are specified in the PSYC spec. If you use |
21
|
|
|
|
|
|
|
# counters according to the spec you can implement your own safety |
22
|
|
|
|
|
|
|
# mechanism best suited for your application. |
23
|
|
|
|
|
|
|
# |
24
|
|
|
|
|
|
|
# Status: the Net::PSYC is pretty much stable. Just details and features |
25
|
|
|
|
|
|
|
# are being refined just as the protocol itself is, so from a software |
26
|
|
|
|
|
|
|
# developer's point of view this library is quite close to a 1.0 release. |
27
|
|
|
|
|
|
|
# After six years of development and usage that's presumably appropriate, too. |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# last snapshot made when i changed this into 0.21 -lynX |
30
|
|
|
|
|
|
|
our $VERSION = '0.21'; |
31
|
|
|
|
|
|
|
|
32
|
5
|
|
|
5
|
|
192056
|
use strict; |
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
5294
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
our (%O, %C, %L, %MMPVARS); |
35
|
|
|
|
|
|
|
our $ANACHRONISM = 0; |
36
|
|
|
|
|
|
|
my ($UDP, $AUTOWATCH, %R, %hosts, %URLS); |
37
|
|
|
|
|
|
|
my ($DEBUG, $NO_UDP, $STATE, $BLOCKING) = (0, 0, 0, 3); |
38
|
|
|
|
|
|
|
# BLOCKING BITS |
39
|
|
|
|
|
|
|
# 1 WRITE (contains CONNECT) |
40
|
|
|
|
|
|
|
# 2 READ |
41
|
|
|
|
|
|
|
# |
42
|
|
|
|
|
|
|
# STATE BITS |
43
|
|
|
|
|
|
|
# 0 <- no bit really, anyway: NO STATE AT ALL. this is not compliant to the |
44
|
|
|
|
|
|
|
# PSYC protocol, should be used by scripts only.. dont send state-ful variables |
45
|
|
|
|
|
|
|
# and dont plan to receive any messages! |
46
|
|
|
|
|
|
|
# 1 RECEIVE/EMULATE STATE |
47
|
|
|
|
|
|
|
# 2 AUTO-SEND STATE |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub FORK () { 0 } |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
%O = ( |
52
|
|
|
|
|
|
|
# arrays suck |
53
|
|
|
|
|
|
|
'_understand_modules' => { }, |
54
|
|
|
|
|
|
|
'_understand_protocols' => 'PSYC/0.9 TCP IP/4, PSYC/0.9 UDP IP/4', |
55
|
|
|
|
|
|
|
'_implementation' => sprintf "Net::PSYC/%s perl/v%vd %s", $VERSION, $^V, $^O |
56
|
|
|
|
|
|
|
); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
%MMPVARS = ( |
59
|
|
|
|
|
|
|
'_source' => 1, |
60
|
|
|
|
|
|
|
'_target' => 1, |
61
|
|
|
|
|
|
|
'_context' => 1, |
62
|
|
|
|
|
|
|
'_count' => 1, |
63
|
|
|
|
|
|
|
'_identification' => 1, |
64
|
|
|
|
|
|
|
'_source_relay' => 1, |
65
|
|
|
|
|
|
|
'_length' => 0, |
66
|
|
|
|
|
|
|
'_fragment' => 0, |
67
|
|
|
|
|
|
|
'_amount_fragments' => 0, |
68
|
|
|
|
|
|
|
'_using_modules' => 0, |
69
|
|
|
|
|
|
|
'_understand_modules' => 0, |
70
|
|
|
|
|
|
|
); |
71
|
|
|
|
|
|
|
|
72
|
61
|
50
|
|
61
|
0
|
405
|
sub ISMMPVAR { exists $MMPVARS{ ($_[0] =~ /^_/) ? $_[0] : substr($_[0], 1) } } |
73
|
61
|
50
|
|
61
|
0
|
461
|
sub MERGEVAR { $MMPVARS{ ($_[0] =~ /^_/) ? $_[0] : substr($_[0], 1) } } |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
our @EXPORT = qw(bind_uniform psyctext make_uniform UNL sendmsg |
76
|
|
|
|
|
|
|
dirty_add dirty_remove dirty_wait |
77
|
|
|
|
|
|
|
parse_uniform dirty_getmsg); # dirty_getmsg is obsolete! |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
our @EXPORT_OK = qw(makeMSG parse_uniform $UDP %C PSYC_PORT PSYCS_PORT |
80
|
|
|
|
|
|
|
UNL W AUTOWATCH BLOCKING sendmsg bind_uniform make_uniform |
81
|
|
|
|
|
|
|
psyctext BASE SRC DEBUG setBASE setSRC setDEBUG |
82
|
|
|
|
|
|
|
register_uniform make_mmp make_psyc parse_mmp parse_psyc |
83
|
|
|
|
|
|
|
send_mmp get_connection |
84
|
|
|
|
|
|
|
register_route register_host same_host dns_lookup |
85
|
|
|
|
|
|
|
psyctext _augment _diminish |
86
|
|
|
|
|
|
|
ISMMPVAR MERGEVAR W0 W1 W2 send_file); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub PSYC_PORT () { 4404 } # default port for PSYC |
90
|
|
|
|
|
|
|
#sub PSYCS_PORT () { 9404 } # non-negotiating TLS port for PSYC |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
my $BASE = '/'; # the UNL pointing to this communication endpoint |
93
|
|
|
|
|
|
|
# with trailing / |
94
|
|
|
|
|
|
|
my $SRC = ''; # default sending object, without leading $BASE |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# inspectors, in form of inline macros |
97
|
0
|
|
|
0
|
0
|
0
|
sub BASE () { $BASE } |
98
|
0
|
|
|
0
|
0
|
0
|
sub SRC () { $SRC } |
99
|
1
|
|
|
1
|
1
|
6
|
sub UNL () { $BASE.$SRC } |
100
|
|
|
|
|
|
|
# settors |
101
|
|
|
|
|
|
|
sub setBASE { |
102
|
0
|
|
|
0
|
0
|
0
|
$BASE = shift; |
103
|
0
|
0
|
|
|
|
0
|
unless ($BASE =~ /\/$/) { |
104
|
0
|
|
|
|
|
0
|
$BASE .= '/'; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
# its useful to register the host here since it may be dyndns |
107
|
0
|
|
|
|
|
0
|
register_host('127.0.0.1', parse_uniform($BASE)->{'host'}); |
108
|
|
|
|
|
|
|
} |
109
|
0
|
|
|
0
|
0
|
0
|
sub setSRC { $SRC = shift; } |
110
|
|
|
|
|
|
|
|
111
|
423
|
|
|
423
|
1
|
2037
|
sub DEBUG () { $DEBUG } |
112
|
|
|
|
|
|
|
sub setDEBUG { |
113
|
0
|
|
|
0
|
1
|
0
|
$DEBUG = shift; |
114
|
0
|
|
|
|
|
0
|
W0('Debug Level %d set for Net::PSYC/%s.', $DEBUG, $VERSION); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# the "other" sub W should be used, but this one is .. TODO |
118
|
|
|
|
|
|
|
sub W { |
119
|
1
|
|
|
1
|
0
|
3
|
my $line = shift; |
120
|
1
|
|
|
|
|
2
|
my $level = shift; |
121
|
1
|
50
|
|
|
|
3
|
$level = 1 unless(defined($level)); |
122
|
1
|
50
|
|
|
|
3
|
print STDERR "\r$line\r\n" if DEBUG() >= $level; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub SW { |
126
|
417
|
|
|
417
|
0
|
477
|
my $level = shift; |
127
|
417
|
100
|
|
|
|
625
|
return if DEBUG() < $level; |
128
|
1
|
|
|
|
|
2
|
my $f = shift; |
129
|
|
|
|
|
|
|
|
130
|
1
|
|
|
|
|
7
|
W(sprintf($f, @_), $level); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub W0 { |
134
|
1
|
|
|
1
|
0
|
2
|
return SW(0, @_); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub W1 { |
138
|
30
|
|
|
30
|
0
|
81
|
return SW(1, @_); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
sub W2 { |
142
|
386
|
|
|
386
|
0
|
907
|
return SW(2, @_); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub BLOCKING { |
146
|
81
|
100
|
|
81
|
0
|
270
|
$BLOCKING = $_[0] if exists $_[0]; |
147
|
81
|
|
|
|
|
461
|
return $BLOCKING; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
sub STATE { |
151
|
10
|
50
|
|
10
|
0
|
21
|
$STATE = $_[0] if exists $_[0]; |
152
|
10
|
|
|
|
|
38
|
return $STATE; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub SSL () { |
156
|
0
|
0
|
|
0
|
0
|
0
|
return 1 if (eval{ |
157
|
0
|
|
|
|
|
0
|
require IO::Socket::SSL; |
158
|
0
|
|
|
|
|
0
|
my $t = $IO::Socket::SSL::VERSION; |
159
|
0
|
0
|
|
|
|
0
|
$t =~ /(\d)\.(\d+)/ && $1 + (0.1**(length($t) - 2))*$2 >= 0.93 |
160
|
|
|
|
|
|
|
}); |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
5
|
|
|
5
|
|
6828
|
use Socket qw(sockaddr_in inet_ntoa inet_aton); |
|
5
|
|
|
|
|
25028
|
|
|
5
|
|
|
|
|
4665
|
|
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# we have to find some solution for W. it really sux the way it is |
166
|
|
|
|
|
|
|
print STDERR "Net::PSYC $VERSION loaded in debug mode.\n\n" if DEBUG; |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
############# |
169
|
|
|
|
|
|
|
# Exporter.. |
170
|
|
|
|
|
|
|
sub import { |
171
|
16
|
|
|
16
|
|
82
|
my $pkg = caller(); |
172
|
16
|
|
|
|
|
91
|
my $list = ' '.join(' ', @_).' '; |
173
|
16
|
|
|
|
|
79
|
$list =~ s/ W / W W0 W1 W2 /g; |
174
|
16
|
|
|
|
|
72
|
$list =~ s/Net::PSYC//g; # |
175
|
16
|
100
|
|
|
|
178
|
if ($list =~ s/Event=(\S+) | :event | :nonblock / /) { |
|
|
50
|
|
|
|
|
|
176
|
4
|
|
|
|
|
13
|
my $match = $1; # the following require resets / unsets $1, at least |
177
|
|
|
|
|
|
|
# some times. |
178
|
4
|
|
|
|
|
7108
|
require Net::PSYC::Event; |
179
|
4
|
100
|
|
|
|
29
|
Net::PSYC::Event::init($match ? $match : 'IO::Select'); |
180
|
3
|
|
|
|
|
256
|
import Net::PSYC::Event qw(watch forget register_uniform |
181
|
|
|
|
|
|
|
unregister_uniform add remove |
182
|
|
|
|
|
|
|
can_read start_loop stop_loop revoke); |
183
|
3
|
|
|
|
|
16
|
push(@EXPORT_OK, qw(watch forget register_uniform |
184
|
|
|
|
|
|
|
unregister_uniform add remove |
185
|
|
|
|
|
|
|
can_read start_loop stop_loop revoke)); |
186
|
3
|
|
|
|
|
12
|
export($pkg, qw(watch forget register_uniform unregister_uniform |
187
|
|
|
|
|
|
|
revoke add remove can_read start_loop stop_loop)); |
188
|
3
|
|
|
|
|
15
|
BLOCKING(0); |
189
|
|
|
|
|
|
|
} elsif ($list =~ s/ :anachronism / /) { |
190
|
0
|
|
|
|
|
0
|
require Net::PSYC::Event; |
191
|
0
|
0
|
|
|
|
0
|
unless (Net::PSYC::Event::init('IO::Select')) { |
192
|
0
|
|
|
|
|
0
|
W0('Huh? What happened to IO::Select? %s', $!); |
193
|
0
|
|
|
|
|
0
|
return 0; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
#its not possible to do negotiation with getMSG.. or you do it yourself |
196
|
0
|
|
|
|
|
0
|
import Net::PSYC::Event qw(watch forget register_uniform |
197
|
|
|
|
|
|
|
unregister_uniform revoke add |
198
|
|
|
|
|
|
|
remove can_read start_loop stop_loop); |
199
|
0
|
|
|
|
|
0
|
push(@EXPORT_OK, qw(watch forget register_uniform |
200
|
|
|
|
|
|
|
unregister_uniform add remove |
201
|
|
|
|
|
|
|
can_read start_loop stop_loop revoke)); |
202
|
0
|
|
|
|
|
0
|
export($pkg, qw(watch forget register_uniform unregister_uniform revoke |
203
|
|
|
|
|
|
|
add remove can_read start_loop stop_loop)); |
204
|
0
|
|
|
|
|
0
|
export($pkg, @EXPORT); |
205
|
0
|
|
|
|
|
0
|
BLOCKING(1); # blocking WRITE |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
15
|
50
|
|
|
|
62
|
if ($list =~ s/ :tls | :ssl | :encrypt / /) { |
209
|
0
|
0
|
|
|
|
0
|
if (SSL) { |
210
|
0
|
|
|
|
|
0
|
$O{'_understand_modules'}->{'_encrypt'} = 1; |
211
|
|
|
|
|
|
|
} else { |
212
|
0
|
|
|
|
|
0
|
W0('You need IO::Socket::SSL to use _encrypt. require() said: %s', |
213
|
|
|
|
|
|
|
$!); |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
} |
216
|
15
|
100
|
|
|
|
55
|
if ($list =~ s/ :zlib | :compress / /) { |
217
|
1
|
50
|
|
|
|
1
|
if (eval { require Net::PSYC::MMP::Compress }) { |
|
1
|
|
|
|
|
680
|
|
218
|
1
|
|
|
|
|
4
|
$O{'_understand_modules'}->{'_compress'} = 1; |
219
|
|
|
|
|
|
|
} else { |
220
|
0
|
|
|
|
|
0
|
W0('You need Compress::Zlib to use _compress. require() said: %s', |
221
|
|
|
|
|
|
|
$!); |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
} |
224
|
15
|
50
|
|
|
|
52
|
if ($list =~ s/ :fork / /) { |
225
|
0
|
|
|
|
|
0
|
eval qq { |
226
|
|
|
|
|
|
|
sub FORK { 1 } |
227
|
|
|
|
|
|
|
}; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
15
|
50
|
|
|
|
69
|
return export($pkg, @EXPORT) unless ($list =~ /\w/); |
231
|
|
|
|
|
|
|
|
232
|
15
|
50
|
|
|
|
74
|
if ($list =~ / :all /) { |
|
|
100
|
|
|
|
|
|
233
|
0
|
|
|
|
|
0
|
export($pkg, @EXPORT); |
234
|
0
|
|
|
|
|
0
|
export($pkg, @EXPORT_OK); |
235
|
|
|
|
|
|
|
} elsif ($list =~ / :base /) { |
236
|
2
|
|
|
|
|
8
|
export($pkg, @EXPORT); |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
15
|
|
|
|
|
35
|
my @subs = grep { $list =~ /$_/ } @EXPORT_OK; |
|
670
|
|
|
|
|
11631
|
|
240
|
15
|
50
|
|
|
|
109
|
if (scalar(@subs)) { |
241
|
15
|
|
|
|
|
50
|
export($pkg, @subs); |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
# export(caller, list); |
247
|
|
|
|
|
|
|
sub export { |
248
|
20
|
|
|
20
|
0
|
35
|
my $pkg = shift; |
249
|
5
|
|
|
5
|
|
44
|
no strict "refs"; |
|
5
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
12973
|
|
250
|
20
|
|
|
|
|
44
|
foreach (@_) { |
251
|
179
|
|
|
|
|
321
|
W2('exporting %s to %s', $_, $pkg); |
252
|
|
|
|
|
|
|
# 'stolen' from Exporter/Heavy.pm |
253
|
179
|
50
|
|
|
|
909
|
if ($_ =~ /^([$%@*&])/) { |
|
|
50
|
|
|
|
|
|
254
|
0
|
|
|
|
|
0
|
*{"${pkg}::$_"} = |
|
0
|
|
|
|
|
0
|
|
255
|
0
|
|
|
|
|
0
|
$1 eq '&' ? \&{$_} : |
256
|
0
|
|
|
|
|
0
|
$1 eq '$' ? \${$_} : |
257
|
0
|
|
|
|
|
0
|
$1 eq '@' ? \@{$_} : |
258
|
0
|
0
|
|
|
|
0
|
$1 eq '%' ? \%{$_} : *{$_}; |
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
259
|
0
|
|
|
|
|
0
|
next; |
260
|
|
|
|
|
|
|
} elsif ($_ =~ /^\>(\w+)/) { |
261
|
0
|
|
|
|
|
0
|
*{$1} = *{"${pkg}::$1"}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
262
|
|
|
|
|
|
|
} else { |
263
|
179
|
|
|
|
|
192
|
*{"${pkg}::$_"} = \&{$_}; |
|
179
|
|
|
|
|
8323
|
|
|
179
|
|
|
|
|
625
|
|
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
# |
269
|
|
|
|
|
|
|
############## |
270
|
|
|
|
|
|
|
############## |
271
|
|
|
|
|
|
|
# DNS |
272
|
|
|
|
|
|
|
# register_route ( ip|ip:port|target, connection ) |
273
|
|
|
|
|
|
|
sub register_route { |
274
|
5
|
|
|
5
|
1
|
66
|
W2('register_route(%s, %s)', $_[0], $_[1]); |
275
|
5
|
|
|
|
|
17
|
$R{$_[0]} = $_[1]; |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# register_host (ip, hosts) |
279
|
|
|
|
|
|
|
# TODO : this is still not very efficient.. 2-way hashes would be very nice |
280
|
|
|
|
|
|
|
sub register_host { |
281
|
11
|
|
|
11
|
1
|
88
|
my $ip = shift; |
282
|
11
|
100
|
|
|
|
35
|
if (exists $hosts{$ip}) { |
283
|
9
|
|
|
|
|
18
|
$ip = $hosts{$ip}; |
284
|
|
|
|
|
|
|
} else { |
285
|
2
|
|
|
|
|
8
|
$hosts{$ip} = $ip; |
286
|
|
|
|
|
|
|
} |
287
|
11
|
|
|
|
|
39
|
W2('register_host(%s, %s)', $ip, join(", ", @_)); |
288
|
11
|
|
|
|
|
25
|
foreach (@_) { |
289
|
11
|
|
|
|
|
22
|
$hosts{$_} = $ip; |
290
|
11
|
|
|
|
|
28
|
foreach my $host (keys %hosts) { |
291
|
19
|
100
|
|
|
|
54
|
if ($hosts{$host} eq $_) { |
292
|
15
|
|
|
|
|
55
|
$hosts{$host} = $ip; |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub dns_lookup { |
299
|
1
|
|
|
1
|
1
|
2
|
my $name = shift; |
300
|
1
|
|
|
|
|
3
|
my $callback = shift; |
301
|
|
|
|
|
|
|
|
302
|
1
|
50
|
|
|
|
6
|
if ($name =~ /\d+\.\d+\.\d+\.\d+/) { |
303
|
1
|
50
|
|
|
|
10
|
return $callback->($name) if $callback; |
304
|
0
|
|
|
|
|
0
|
return $name; |
305
|
|
|
|
|
|
|
} |
306
|
0
|
|
|
|
|
0
|
my $addr = gethostbyname($name); |
307
|
0
|
0
|
|
|
|
0
|
if ($addr) { |
308
|
0
|
|
|
|
|
0
|
my $ip = join('.', (unpack('C4', $addr))); |
309
|
0
|
|
|
|
|
0
|
W2('dns_lookup(%s) == %s', $name, $ip); |
310
|
0
|
|
|
|
|
0
|
register_host($ip, $name); |
311
|
0
|
0
|
|
|
|
0
|
return $callback->($ip) if $callback; |
312
|
0
|
|
|
|
|
0
|
return $ip; |
313
|
|
|
|
|
|
|
} else { |
314
|
0
|
0
|
|
|
|
0
|
return $callback->(0) if $callback; |
315
|
0
|
|
|
|
|
0
|
return 0; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub same_host { |
320
|
19
|
|
|
19
|
1
|
44
|
my ($one, $two, $callback) = @_; |
321
|
19
|
|
|
|
|
115
|
W2('same_host(%s, %s)', $one, $two); |
322
|
19
|
50
|
33
|
|
|
189
|
if (($one && $two) && (exists $hosts{$one} || dns_lookup($one)) && (exists $hosts{$two} || dns_lookup($two))) { |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
323
|
19
|
100
|
|
|
|
41
|
if ($callback) { |
324
|
2
|
|
|
|
|
9
|
return $callback->($hosts{$_[0]} eq $hosts{$_[1]}); |
325
|
|
|
|
|
|
|
} |
326
|
17
|
|
|
|
|
157
|
return $hosts{$_[0]} eq $hosts{$_[1]}; |
327
|
|
|
|
|
|
|
} |
328
|
0
|
0
|
|
|
|
0
|
$callback->(0) if ($callback); |
329
|
0
|
|
|
|
|
0
|
return 0; |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
# |
332
|
|
|
|
|
|
|
############## |
333
|
|
|
|
|
|
|
############## |
334
|
|
|
|
|
|
|
# |
335
|
|
|
|
|
|
|
sub use_modules { |
336
|
0
|
|
|
0
|
0
|
0
|
foreach (@_) { |
337
|
0
|
0
|
|
|
|
0
|
unless (/_state|_encrypt|_compress|_fragments|_length|_context/) { |
338
|
0
|
|
|
|
|
0
|
W0('No suchs MMP module: %s', $_); |
339
|
|
|
|
|
|
|
} |
340
|
0
|
|
|
|
|
0
|
$O{'_understand_modules'}->{$_} = 1; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
# |
344
|
|
|
|
|
|
|
############## |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
sub bind_uniform { |
347
|
2
|
|
50
|
2
|
1
|
11
|
my $source = shift || 'psyc://:/'; # get yourself any tcp and udp port |
348
|
|
|
|
|
|
|
# $source or croak 'usage: bind_uniform( $UNI )'; |
349
|
|
|
|
|
|
|
|
350
|
2
|
|
|
|
|
10
|
my ($user, $host, $port, $prots, $object) = parse_uniform($source); |
351
|
2
|
|
|
|
|
4
|
my ($ip, $return); |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
|
354
|
2
|
50
|
|
|
|
15
|
register_host('127.0.0.1', $host) if ($host); |
355
|
|
|
|
|
|
|
|
356
|
2
|
100
|
66
|
|
|
17
|
if (!$prots || $prots =~ /d/oi) { # bind a datagram |
357
|
1
|
|
|
|
|
941
|
require Net::PSYC::Datagram; |
358
|
1
|
|
|
|
|
9
|
my $sock = Net::PSYC::Datagram->new($host, $port); |
359
|
1
|
50
|
|
|
|
4
|
if (ref $sock) { |
360
|
1
|
|
|
|
|
2
|
$UDP = $sock; |
361
|
1
|
|
|
|
|
2
|
$return = $UDP; |
362
|
1
|
|
|
|
|
3
|
$port = $return->{'PORT'}; |
363
|
|
|
|
|
|
|
} else { |
364
|
0
|
|
|
|
|
0
|
W0('UDP bind to %s:%s failed: %s', $host, $port, $sock); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
} |
367
|
2
|
100
|
66
|
|
|
17
|
if (!$prots || $prots =~ /c/oi) { # bind a circuit |
368
|
1
|
|
|
|
|
778
|
require Net::PSYC::Circuit; |
369
|
1
|
|
|
|
|
12
|
my $sock = Net::PSYC::Circuit->listen($host, $port, \%O); |
370
|
1
|
50
|
|
|
|
5
|
if (ref $sock) { |
371
|
1
|
|
33
|
|
|
4
|
$host ||= $sock->{'IP'}; |
372
|
1
|
|
|
|
|
3
|
$port = $sock->{'PORT'}; |
373
|
1
|
|
|
|
|
6
|
$L{$host.':'.$port} = $sock; |
374
|
|
|
|
|
|
|
# tcp-sockets watch themselfes |
375
|
1
|
|
|
|
|
3
|
$return = $L{$host.':'.$port}; |
376
|
1
|
|
|
|
|
3
|
$port = $return->{'PORT'}; |
377
|
|
|
|
|
|
|
} else { |
378
|
0
|
|
|
|
|
0
|
W0('TCP bind to %s:%s failed: %s', $host, $port, $sock); |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
} |
381
|
2
|
50
|
33
|
|
|
32
|
if ($prots && $prots =~ /s/oi) { # bind an SSL |
382
|
0
|
|
|
|
|
0
|
die "We don't allow binding of SSL sockets because SSL should". |
383
|
|
|
|
|
|
|
" be negotiated anyway"; |
384
|
|
|
|
|
|
|
} |
385
|
2
|
50
|
|
|
|
8
|
return unless ($return); |
386
|
|
|
|
|
|
|
# how does one check for fqdn properly? |
387
|
|
|
|
|
|
|
# TODO $ip is undef ! |
388
|
2
|
50
|
0
|
|
|
11
|
my $unlhost = $host =~ /\./ ? $host : $ip || '127.0.0.1'; |
389
|
2
|
50
|
|
|
|
10
|
warn 'Could not find my own hostname or IP address!?' unless $unlhost; |
390
|
|
|
|
|
|
|
|
391
|
2
|
|
|
|
|
6
|
$SRC = $object; |
392
|
2
|
|
|
|
|
9
|
$BASE = &make_uniform($user, $unlhost, $port, $prots); |
393
|
2
|
|
|
|
|
12
|
W1('My UNL is %s%s', $BASE, $SRC); |
394
|
2
|
50
|
|
|
|
20
|
return $return if (defined wantarray); |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
# shutdown a connection-object.. |
398
|
|
|
|
|
|
|
sub shutdown { |
399
|
0
|
|
|
0
|
0
|
0
|
my $obj = shift; |
400
|
0
|
|
|
|
|
0
|
forget($obj); # stop delivering packets .. |
401
|
0
|
0
|
|
|
|
0
|
$obj->{'SOCKET'}->close() if ($obj->{'SOCKET'}); |
402
|
0
|
|
|
|
|
0
|
foreach (keys %C) { |
403
|
0
|
0
|
|
|
|
0
|
delete $C{$_} if ($C{$_} eq $obj); |
404
|
|
|
|
|
|
|
} |
405
|
0
|
|
|
|
|
0
|
foreach (keys %R) { |
406
|
0
|
0
|
|
|
|
0
|
delete $R{$_} if ($R{$_} eq $obj); |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# get_connection ( target ) |
411
|
|
|
|
|
|
|
sub get_connection { |
412
|
17
|
|
|
17
|
0
|
2631
|
my $target = shift; |
413
|
|
|
|
|
|
|
|
414
|
17
|
|
|
|
|
31
|
my ($user, $host, $port, $prots, $object) = parse_uniform($target); |
415
|
|
|
|
|
|
|
|
416
|
17
|
50
|
|
|
|
48
|
unless (defined $user) { |
417
|
0
|
|
|
|
|
0
|
return 0; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
# hm.. irgendwo müssen wir aus undef 4404 machen.. |
420
|
|
|
|
|
|
|
# goto sucks.. i will correct that later! -elridion |
421
|
|
|
|
|
|
|
# goto rocks.. please keep it.. i love goto ;-) -lynX |
422
|
|
|
|
|
|
|
# |
423
|
17
|
50
|
33
|
|
|
84
|
if ( !$prots || $prots =~ /c/i ) { # TCP |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
424
|
17
|
|
50
|
|
|
38
|
$port ||= PSYC_PORT; |
425
|
17
|
|
|
|
|
76
|
goto TCP; |
426
|
|
|
|
|
|
|
} elsif ( $prots =~ /d/i ) { # UDP |
427
|
0
|
|
0
|
|
|
0
|
$port ||= PSYC_PORT; |
428
|
0
|
|
|
|
|
0
|
goto UDP; |
429
|
|
|
|
|
|
|
} elsif ( $prots =~ /s/i ) { |
430
|
0
|
|
0
|
|
|
0
|
$port ||= PSYCS_PORT(); |
431
|
0
|
|
|
|
|
0
|
goto TCP; |
432
|
|
|
|
|
|
|
} else { # AI |
433
|
0
|
|
|
|
|
0
|
goto TCP; |
434
|
|
|
|
|
|
|
# if (!$NO_UDP) { |
435
|
|
|
|
|
|
|
# goto UDP; |
436
|
|
|
|
|
|
|
# } else { # TCP |
437
|
|
|
|
|
|
|
# goto TCP; |
438
|
|
|
|
|
|
|
# } |
439
|
|
|
|
|
|
|
} |
440
|
17
|
|
|
|
|
93
|
TCP: |
441
|
|
|
|
|
|
|
require Net::PSYC::Circuit; |
442
|
17
|
|
|
|
|
571
|
my @addresses = gethostbyname($host); |
443
|
17
|
50
|
|
|
|
50
|
if (@addresses > 4) { |
444
|
17
|
|
|
|
|
93
|
$host = inet_ntoa($addresses[4]); |
445
|
|
|
|
|
|
|
} |
446
|
17
|
100
|
|
|
|
61
|
if (exists $C{$host.':'.$port}) { # we have a connection |
447
|
16
|
|
|
|
|
87
|
return $C{$host.':'.$port}; |
448
|
|
|
|
|
|
|
} |
449
|
1
|
50
|
33
|
|
|
18
|
if ($R{$target} || $R{$host.':'.$port} || $R{$host}) { |
|
|
|
33
|
|
|
|
|
450
|
0
|
|
0
|
|
|
0
|
return $R{$target} || $R{$host.':'.$port} || $R{$host}; |
451
|
|
|
|
|
|
|
} |
452
|
1
|
|
|
|
|
6
|
require Net::PSYC::Circuit; |
453
|
1
|
|
|
|
|
10
|
$C{$host.':'.$port} = Net::PSYC::Circuit->connect($host, $port, \%O); |
454
|
1
|
|
|
|
|
7
|
return $C{$host.':'.$port}; |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
UDP: |
457
|
0
|
0
|
|
|
|
0
|
unless ($UDP) { |
458
|
0
|
|
|
|
|
0
|
require Net::PSYC::Datagram; |
459
|
0
|
|
|
|
|
0
|
$UDP = Net::PSYC::Datagram->new; |
460
|
|
|
|
|
|
|
} |
461
|
0
|
|
|
|
|
0
|
return $UDP; |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
# sendmsg ( target, mc, data, vars[, source || MMP-vars] ) |
466
|
|
|
|
|
|
|
sub sendmsg { |
467
|
10
|
|
|
10
|
1
|
589
|
my ($MMPvars, $state); |
468
|
10
|
50
|
33
|
|
|
26
|
goto FIRE if (!STATE() && BLOCKING() & 2); |
469
|
|
|
|
|
|
|
|
470
|
10
|
50
|
|
|
|
28
|
if (ref $_[0]) { # this is a $self->sendmsg |
471
|
|
|
|
|
|
|
#hmm |
472
|
0
|
|
|
|
|
0
|
$state = shift; |
473
|
0
|
|
|
|
|
0
|
$MMPvars = $_[4]; |
474
|
0
|
0
|
0
|
|
|
0
|
$MMPvars = { '_source' => $MMPvars } if ($MMPvars && !ref $MMPvars); |
475
|
|
|
|
|
|
|
} else { |
476
|
|
|
|
|
|
|
# now we try to find out who you are. |
477
|
10
|
|
|
|
|
13
|
$MMPvars = $_[4]; |
478
|
10
|
50
|
66
|
|
|
42
|
$MMPvars = { '_source' => $MMPvars } if ($MMPvars && !ref $MMPvars); |
479
|
10
|
50
|
|
|
|
28
|
if (exists $MMPvars->{'_source'}) { |
480
|
0
|
|
|
|
|
0
|
$state = Net::PSYC::Event::unl2wrapper($MMPvars->{'_source'}); |
481
|
|
|
|
|
|
|
} |
482
|
10
|
50
|
|
|
|
33
|
unless ($state) { |
483
|
10
|
|
|
|
|
17
|
$state = caller(); |
484
|
10
|
|
|
|
|
51
|
$state = Net::PSYC::Event::unl2wrapper($state); |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
} |
488
|
10
|
|
|
|
|
23
|
FIRE: |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
my ($target, $mc, $data, $vars) = @_; |
491
|
10
|
50
|
|
|
|
22
|
$target or die 'usage: sendmsg( $UNL, $method, $data, %vars )'; |
492
|
|
|
|
|
|
|
|
493
|
10
|
50
|
|
|
|
31
|
unless ($MMPvars) { |
|
|
50
|
|
|
|
|
|
494
|
0
|
|
|
|
|
0
|
$MMPvars = {}; |
495
|
|
|
|
|
|
|
} elsif (!ref $MMPvars) { |
496
|
0
|
|
|
|
|
0
|
$MMPvars = { '_source' => $MMPvars }; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
10
|
|
33
|
|
|
45
|
$MMPvars->{'_target'} ||= $target; |
500
|
|
|
|
|
|
|
|
501
|
10
|
|
|
|
|
23
|
my $connection = get_connection( $target ); |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
# TODO do a retry here in case we have nonblocking writes! |
504
|
|
|
|
|
|
|
# also. catch the return-error and make a W. we want no murks |
505
|
10
|
50
|
|
|
|
27
|
return 'SendMSG failed: '.$connection if (!ref $connection); |
506
|
10
|
|
|
|
|
20
|
my $d = make_psyc( $mc, $data, $vars, $state, $target); |
507
|
10
|
|
|
|
|
39
|
return $connection->send( $target, $d, $MMPvars ); |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
# send_mmp (target, data, vars) |
511
|
|
|
|
|
|
|
sub send_mmp { |
512
|
1
|
|
|
1
|
1
|
20
|
my ( $target, $data, $vars ) = @_; |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
# maybe we can check for the caller of sendmsg and use his unl as |
515
|
|
|
|
|
|
|
# source.. TODO ( works with Event only ). stone perloo |
516
|
1
|
50
|
|
|
|
5
|
$target or die 'usage: send_mmp( $UNL, $MMPdata, %MMPvars )'; |
517
|
|
|
|
|
|
|
# |
518
|
|
|
|
|
|
|
# presence of a method or data is not mandatory: |
519
|
|
|
|
|
|
|
# a simple modification of a variable may be sent as well, |
520
|
|
|
|
|
|
|
# although that only starts making sense once _state is implemented. |
521
|
1
|
50
|
|
|
|
5
|
if ($vars) { |
522
|
0
|
|
0
|
|
|
0
|
$vars->{'_target'} ||= $target; |
523
|
|
|
|
|
|
|
} else { |
524
|
1
|
|
|
|
|
9
|
$vars = { _target => $target }; |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
1
|
|
|
|
|
3
|
my $connection = get_connection( $target ); |
528
|
1
|
50
|
|
|
|
10
|
return 0 if (!$connection); |
529
|
1
|
|
|
|
|
5
|
return $connection->send( $target, $data, $vars ); |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
# send a file. this one is very straightforward.. may kill the other sides |
533
|
|
|
|
|
|
|
# perlpsyc by sending huge files at once. |
534
|
|
|
|
|
|
|
sub send_file { |
535
|
0
|
|
|
0
|
0
|
0
|
my ( $target, $fn, $vars, $offset, $length ) = @_; |
536
|
|
|
|
|
|
|
|
537
|
0
|
0
|
|
|
|
0
|
return 0 unless (-e $fn); |
538
|
0
|
|
|
|
|
0
|
my (@file); |
539
|
|
|
|
|
|
|
|
540
|
0
|
0
|
|
|
|
0
|
require Net::PSYC::Tie::File unless (%Net::PSYC::Tie::File::); |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
# 1024 is maybe too small. we should think about making |
543
|
|
|
|
|
|
|
# that dependend on the bandwidth |
544
|
0
|
0
|
|
|
|
0
|
my $o = tie @file, 'Net::PSYC::Tie::File', $fn, 6024, int($offset), |
545
|
|
|
|
|
|
|
int($length) |
546
|
|
|
|
|
|
|
or return 0; |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
# set all vars to proper values. |
549
|
0
|
|
|
|
|
0
|
$offset = $o->{'OFFSET'}; |
550
|
0
|
0
|
|
|
|
0
|
$vars->{'_seek_resume'} = $offset if $offset; |
551
|
0
|
|
|
|
|
0
|
$vars->{'_size_file'} = $o->{'SIZE'}; |
552
|
|
|
|
|
|
|
|
553
|
0
|
0
|
|
|
|
0
|
if ($length) { |
554
|
0
|
|
|
|
|
0
|
$length = $o->{'RANGE'}; |
555
|
0
|
|
|
|
|
0
|
$vars->{'_size_resume'} = $o->{'RANGE'}; |
556
|
0
|
|
|
|
|
0
|
$vars->{'_size_file'} = $o->{'SIZE'}; |
557
|
|
|
|
|
|
|
} else { |
558
|
0
|
|
|
|
|
0
|
$length = $o->{'SIZE'}; |
559
|
0
|
|
|
|
|
0
|
$vars->{'_size_file'} = $length; |
560
|
|
|
|
|
|
|
} |
561
|
0
|
|
0
|
|
|
0
|
$vars->{'_name_file'} ||= substr($fn, rindex($fn, '/')+1); |
562
|
0
|
|
|
|
|
0
|
my $header; |
563
|
|
|
|
|
|
|
# looks stupid to first create the hash and then run through it again. |
564
|
0
|
|
|
|
|
0
|
foreach my $key (keys %$vars) { |
565
|
0
|
|
|
|
|
0
|
my $mod = substr($key, 0, 1); |
566
|
0
|
0
|
|
|
|
0
|
if ($mod ne '_') { |
567
|
0
|
|
|
|
|
0
|
$key = substr($key, 1); |
568
|
|
|
|
|
|
|
} else { |
569
|
0
|
|
|
|
|
0
|
$mod = ':'; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
0
|
0
|
|
|
|
0
|
$header .= make_header($mod, $key, $vars->{$key}) unless ISMMPVAR($key); |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
# new undocumented feature. sets _length to the apropriate value .. |
576
|
0
|
|
|
|
|
0
|
$vars->{'_length'} = undef; |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
# one should not forget about known errors. maybe i should carry a little |
579
|
|
|
|
|
|
|
# notebook to keep track of things that come to my mind while i am not |
580
|
|
|
|
|
|
|
# at my comp |
581
|
0
|
|
|
|
|
0
|
unshift @file, $header."_data_file\n"; |
582
|
|
|
|
|
|
|
|
583
|
0
|
|
|
|
|
0
|
return !send_mmp($target, \@file, $vars); |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
sub psyctext { |
587
|
2
|
|
|
2
|
1
|
1513
|
my $text = shift; |
588
|
2
|
0
|
|
|
|
7
|
$text =~ s/\[\?\ (_\w+)\](.+?)\[\;\]/(exists $_[0]->{$1}) ? $2 : ""/ge; |
|
0
|
|
|
|
|
0
|
|
589
|
2
|
0
|
|
|
|
6
|
$text =~ s/\[\?\ (_\w+)\](.+?)\[\:\](.+?)\[\;\]/(exists $_[0]->{$1}) ? $2 : $3/ge; |
|
0
|
|
|
|
|
0
|
|
590
|
2
|
0
|
|
|
|
6
|
$text =~ s/\[\!\ (_\w+)\](.+?)\[\;\]/(!exists $_[0]->{$1}) ? $2 : ""/ge; |
|
0
|
|
|
|
|
0
|
|
591
|
2
|
0
|
|
|
|
6
|
$text =~ s/\[\!\ (_\w+)\](.+?)\[\:\](.+?)\[\;\]/(!exists $_[0]->{$1}) ? $2 : $3/ge; |
|
0
|
|
|
|
|
0
|
|
592
|
2
|
50
|
|
|
|
29
|
$text =~ s/\[(_\w+)\]/my $ref = ((exists $_[0]->{$1}) ? $_[0]->{$1} : ''); (ref $ref eq 'ARRAY') ? join(' ', @$ref) : $ref;/ge; |
|
2
|
50
|
|
|
|
14
|
|
|
2
|
|
|
|
|
11
|
|
593
|
2
|
|
|
|
|
17
|
return $text; |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
sub parse_mmp { |
597
|
5
|
|
|
5
|
|
5445
|
use bytes; |
|
5
|
|
|
|
|
44
|
|
|
5
|
|
|
|
|
28
|
|
598
|
27
|
|
|
27
|
0
|
809
|
my $d = shift; |
599
|
27
|
|
|
|
|
39
|
my $lf = shift; |
600
|
27
|
|
|
|
|
33
|
my $o; |
601
|
27
|
50
|
|
|
|
63
|
if (ref $lf) { |
602
|
0
|
|
|
|
|
0
|
$o = $lf; |
603
|
0
|
|
|
|
|
0
|
$lf = "\n"; |
604
|
|
|
|
|
|
|
} else { |
605
|
27
|
|
|
|
|
31
|
$o = shift; |
606
|
27
|
|
100
|
|
|
71
|
$lf ||= "\n"; |
607
|
|
|
|
|
|
|
} |
608
|
27
|
|
50
|
|
|
57
|
$lf ||= "\n"; |
609
|
|
|
|
|
|
|
|
610
|
27
|
|
|
|
|
31
|
my $l = length($lf); |
611
|
|
|
|
|
|
|
|
612
|
27
|
|
|
|
|
45
|
my $vars = {}; |
613
|
27
|
|
|
|
|
33
|
my $ref; |
614
|
27
|
50
|
|
|
|
65
|
if (ref $d eq 'SCALAR') { |
615
|
27
|
|
|
|
|
36
|
$ref = 1; |
616
|
|
|
|
|
|
|
} else { |
617
|
0
|
|
|
|
|
0
|
$d = \$d; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
27
|
|
|
|
|
34
|
my $length; |
621
|
27
|
|
|
|
|
39
|
my ($a, $b) = ( 0, 0 ); |
622
|
27
|
|
|
|
|
31
|
my ($lmod, $lvar, $lval, $data); |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
# TODO. stop checking for $data, use last instead. |
625
|
|
|
|
|
|
|
# maybe |
626
|
27
|
|
66
|
|
|
235
|
LINE: while (!defined($data) && $a < length($$d) && |
|
|
|
66
|
|
|
|
|
627
|
|
|
|
|
|
|
-1 != ($b = index($$d, $lf, $a))) { |
628
|
77
|
|
|
|
|
361
|
my $line = substr($$d, $a, $b - $a); |
629
|
77
|
|
|
|
|
88
|
my ($mod, $var, $val); |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
#W1("parse_mmp: '$line'"); |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# TODO put that into _one_ regexp |
634
|
77
|
100
|
66
|
|
|
480
|
if ($line =~ /^([+-:=-?])(_\w+)[\t\ ](.*)$/ || |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
635
|
|
|
|
|
|
|
$line =~ /^([+-:=-?])(_\w+)$/) { |
636
|
50
|
|
|
|
|
150
|
($mod, $var, $val) = ($1, $2, $3); |
637
|
|
|
|
|
|
|
#W0('mod: %s, var: %s, val: %s', $mod, $var, $val); |
638
|
50
|
50
|
|
|
|
193
|
$length = int($val) if ($var eq '_length'); |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
} elsif ($line eq '') { |
641
|
24
|
50
|
|
|
|
86
|
if ($length) { |
|
|
100
|
|
|
|
|
|
642
|
0
|
0
|
|
|
|
0
|
if (length($$d) < $b + $length + 2*$l) { |
643
|
|
|
|
|
|
|
# return amount of bytes missing |
644
|
0
|
|
|
|
|
0
|
return length($$d) - $b - $length - 2*$l; |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
|
647
|
0
|
0
|
|
|
|
0
|
unless ("$lf.$lf" eq substr($$d, $b + $l + $length, 2*$l + 1)) { |
648
|
0
|
|
|
|
|
0
|
return (0, "The _length specified does not match the packet."); |
649
|
|
|
|
|
|
|
} |
650
|
0
|
|
|
|
|
0
|
$length += $b+$l; |
651
|
|
|
|
|
|
|
} elsif (".$lf" eq substr($$d, $b+$l, 1+$l)) { |
652
|
|
|
|
|
|
|
# the 2. variant of a mmp-packet without data |
653
|
2
|
|
|
|
|
5
|
substr($$d, 0, $b+$l*2+1 , ''); |
654
|
2
|
|
|
|
|
4
|
$data = ''; |
655
|
|
|
|
|
|
|
} else { |
656
|
22
|
|
|
|
|
54
|
$length = index($$d, "$lf.$lf", $b+$l); |
657
|
|
|
|
|
|
|
# means: the packet is incomplete. we have to do something |
658
|
|
|
|
|
|
|
# about too long packets! TODO |
659
|
22
|
50
|
|
|
|
82
|
return if ($length == -1); |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
|
662
|
24
|
100
|
|
|
|
50
|
unless (defined $data) { |
663
|
22
|
|
|
|
|
63
|
$data = substr($$d, 0, $length + 2*$l + 1, ''); |
664
|
22
|
|
|
|
|
51
|
$data = substr($data, $b + $l, $length - $b - $l); |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
} elsif ($line eq '.') { |
667
|
|
|
|
|
|
|
# packet stops here. means we have no data |
668
|
3
|
|
|
|
|
9
|
substr($$d, 0, $b + $l, ''); |
669
|
3
|
|
|
|
|
7
|
$data = ''; |
670
|
|
|
|
|
|
|
} elsif ($line =~ /^([+-:=-?])[\t\ ](.*)$/) { |
671
|
0
|
0
|
|
|
|
0
|
if (!$lmod) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
672
|
0
|
|
|
|
|
0
|
return (0, "Lonesome list continuation."); |
673
|
|
|
|
|
|
|
} elsif ($1 ne $lmod) { |
674
|
0
|
|
|
|
|
0
|
return (0, "Mixed modifiers in list continuation."); |
675
|
|
|
|
|
|
|
} elsif ($1 eq '-') { |
676
|
0
|
|
|
|
|
0
|
return (0, "Diminish of a list."); |
677
|
|
|
|
|
|
|
} elsif (!$lval) { |
678
|
0
|
|
|
|
|
0
|
return (0, "Empty variable in list."); |
679
|
|
|
|
|
|
|
} |
680
|
0
|
0
|
|
|
|
0
|
if (ref $lval eq 'ARRAY') { |
681
|
0
|
|
|
|
|
0
|
push(@$lval, $2); |
682
|
|
|
|
|
|
|
} else { |
683
|
0
|
|
|
|
|
0
|
$lval = [ $lval, $2 ]; |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
0
|
|
|
|
|
0
|
goto NEXT; |
687
|
|
|
|
|
|
|
} elsif ($line =~ /^\t(.*)$/) { |
688
|
0
|
0
|
|
|
|
0
|
unless ($lval) { |
689
|
|
|
|
|
|
|
# raise an error here! |
690
|
0
|
|
|
|
|
0
|
return (0, "Lonesome variable continuation."); |
691
|
|
|
|
|
|
|
} |
692
|
0
|
|
|
|
|
0
|
$lval .= $1; |
693
|
0
|
|
|
|
|
0
|
goto NEXT; |
694
|
|
|
|
|
|
|
} else { |
695
|
0
|
|
|
|
|
0
|
return (0, "I cannot parse that line: '$line'"); |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
77
|
100
|
|
|
|
137
|
if ($lvar) { |
699
|
50
|
100
|
|
|
|
106
|
if ($lmod eq ':') { |
|
|
50
|
|
|
|
|
|
700
|
47
|
|
|
|
|
115
|
$vars->{$lvar} = $lval; |
701
|
|
|
|
|
|
|
} elsif (ref $o) { |
702
|
|
|
|
|
|
|
# TODO maybe its even better to use an hash instead of an |
703
|
|
|
|
|
|
|
# object. i cannot imagine a case in which the flexibility |
704
|
|
|
|
|
|
|
# of a funcall is needed. even if there was one, a tied hash |
705
|
|
|
|
|
|
|
# would do the trick |
706
|
0
|
0
|
|
|
|
0
|
if ($lmod eq '=') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
707
|
0
|
|
|
|
|
0
|
$o->assign($lvar, $lval); |
708
|
|
|
|
|
|
|
} elsif ($lmod eq '+') { |
709
|
0
|
|
|
|
|
0
|
$o->augment($lvar, $lval); |
710
|
|
|
|
|
|
|
} elsif ($lmod eq '-') { |
711
|
0
|
|
|
|
|
0
|
$o->diminish($lvar, $lval); |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
} else { |
714
|
3
|
|
|
|
|
25
|
$vars->{$lmod.$lvar} = $lval; |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
|
717
|
50
|
100
|
|
|
|
728
|
$vars->{$lvar} = $lval if ($lmod eq '='); |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
|
720
|
77
|
|
|
|
|
124
|
($lmod, $lvar, $lval) = ($mod, $var, $val); |
721
|
77
|
|
|
|
|
502
|
NEXT: |
722
|
|
|
|
|
|
|
$a = $b + $l; |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
# er. i dont know yet. check that TODO |
725
|
27
|
50
|
|
|
|
59
|
return unless defined $data; |
726
|
27
|
|
|
|
|
102
|
return ($vars, $data); |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
sub parse_psyc { |
730
|
|
|
|
|
|
|
|
731
|
16
|
|
|
16
|
0
|
27
|
my $d = shift; |
732
|
16
|
50
|
|
|
|
38
|
$d = $$d if (ref $d eq 'SCALAR'); |
733
|
|
|
|
|
|
|
|
734
|
16
|
|
|
|
|
23
|
my $linefeed = shift; |
735
|
|
|
|
|
|
|
=state |
736
|
|
|
|
|
|
|
my $o; |
737
|
|
|
|
|
|
|
if (ref $linefeed) { |
738
|
|
|
|
|
|
|
$o = $linefeed; |
739
|
|
|
|
|
|
|
$linefeed = "\n"; |
740
|
|
|
|
|
|
|
} else { |
741
|
|
|
|
|
|
|
$linefeed ||= "\n"; |
742
|
|
|
|
|
|
|
$o = shift; |
743
|
|
|
|
|
|
|
} |
744
|
|
|
|
|
|
|
my $iscontext = shift; |
745
|
|
|
|
|
|
|
my $source = shift; |
746
|
|
|
|
|
|
|
=cut |
747
|
16
|
|
50
|
|
|
38
|
$linefeed ||= "\n"; |
748
|
|
|
|
|
|
|
|
749
|
16
|
|
|
|
|
33
|
my ($mc, $data, $vars) = ( '', '', {} ); |
750
|
16
|
|
|
|
|
29
|
my ($a, $b) = (0, 0); # the interval we are parsing |
751
|
16
|
|
|
|
|
26
|
my ($lmod, $lvar, $lval); |
752
|
|
|
|
|
|
|
|
753
|
16
|
|
66
|
|
|
118
|
while (!$mc && $a < length($d) && |
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
754
|
|
|
|
|
|
|
(-1 != ($b = index($d, $linefeed, $a)) || ($b = length($d)))) { |
755
|
19
|
|
|
|
|
51
|
my $line = substr($d, $a, $b - $a); |
756
|
|
|
|
|
|
|
#W1('line: "%s"', $line); |
757
|
19
|
|
|
|
|
23
|
my ($mod, $var, $val); |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
# this could be combined .. TODO |
760
|
19
|
100
|
66
|
|
|
395
|
if ($line =~ /^([+-:=-?])(_\w+)[\t\ ](.*)$/ || |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
761
|
|
|
|
|
|
|
$line =~ /^([+-:=-?])(_\w+)$/) { |
762
|
3
|
|
|
|
|
12
|
($mod, $var, $val) = ($1, $2, $3); |
763
|
3
|
50
|
|
|
|
13
|
$val = [ $val ] if ($var =~ /^_list/); |
764
|
|
|
|
|
|
|
} elsif ($line =~ /^([+-:=-?])[\t\ ](.*)$/) { |
765
|
0
|
0
|
|
|
|
0
|
if (!$lmod) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
766
|
0
|
|
|
|
|
0
|
return (0, "Lonesome list continuation."); |
767
|
|
|
|
|
|
|
} elsif ($1 ne $lmod) { |
768
|
0
|
|
|
|
|
0
|
return (0, "Mixed modifiers in list continuation."); |
769
|
|
|
|
|
|
|
} elsif ($1 eq '-') { |
770
|
0
|
|
|
|
|
0
|
return (0, "Diminish of a list."); |
771
|
|
|
|
|
|
|
} elsif (!$lval) { |
772
|
0
|
|
|
|
|
0
|
return (0, "Empty variable in list."); |
773
|
|
|
|
|
|
|
} |
774
|
0
|
0
|
|
|
|
0
|
if (ref $lval eq 'ARRAY') { |
775
|
0
|
|
|
|
|
0
|
push(@$lval, $2); |
776
|
|
|
|
|
|
|
} else { |
777
|
0
|
|
|
|
|
0
|
$lval = [ $lval, $2 ]; |
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
|
780
|
0
|
|
|
|
|
0
|
goto NEXT; |
781
|
|
|
|
|
|
|
} elsif ($line =~ /^\t(.*)$/) { |
782
|
0
|
0
|
|
|
|
0
|
unless ($lvar) { |
783
|
|
|
|
|
|
|
# raise an error here! |
784
|
0
|
|
|
|
|
0
|
return (0, "Lonesome variable continuation."); |
785
|
|
|
|
|
|
|
} |
786
|
0
|
|
|
|
|
0
|
$lval .= "\n".$1; |
787
|
0
|
|
|
|
|
0
|
goto NEXT; |
788
|
|
|
|
|
|
|
# variable continuation |
789
|
|
|
|
|
|
|
} elsif ($line =~ /^(_\w+)$/) { |
790
|
16
|
|
|
|
|
49
|
$mc = $1; |
791
|
16
|
|
|
|
|
44
|
$mc =~ s/^(?:_talk|_conversation|_converse)/_message/; |
792
|
|
|
|
|
|
|
} else { |
793
|
0
|
|
|
|
|
0
|
return (0, "Could not parse: '".$line."'"); |
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
19
|
100
|
|
|
|
41
|
if ($lvar) { |
797
|
3
|
50
|
33
|
|
|
14
|
if ($lvar =~ /^_list/ && ref $lval ne 'ARRAY') { |
798
|
0
|
|
|
|
|
0
|
$lval = [ $lval ]; |
799
|
|
|
|
|
|
|
} |
800
|
3
|
50
|
|
|
|
10
|
if ($lmod eq ':') { |
801
|
3
|
|
|
|
|
10
|
$vars->{$lvar} = $lval; |
802
|
|
|
|
|
|
|
=state |
803
|
|
|
|
|
|
|
} elsif (ref $o) { |
804
|
|
|
|
|
|
|
# TODO same as above. I will change that. |
805
|
|
|
|
|
|
|
if ($lmod eq '=') { |
806
|
|
|
|
|
|
|
$o->assign($lvar, $lval, $source, $iscontext); |
807
|
|
|
|
|
|
|
} elsif ($lmod eq '+') { |
808
|
|
|
|
|
|
|
$o->augment($lvar, $lval, $source, $iscontext); |
809
|
|
|
|
|
|
|
} elsif ($lmod eq '-') { |
810
|
|
|
|
|
|
|
$o->diminish($lvar, $lval, $source, $iscontext); |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
=cut |
813
|
|
|
|
|
|
|
} else { |
814
|
0
|
|
|
|
|
0
|
$vars->{$lmod.$lvar} = $lval; |
815
|
|
|
|
|
|
|
} |
816
|
3
|
50
|
|
|
|
9
|
$vars->{$lvar} = $lval if ($lmod eq '='); |
817
|
|
|
|
|
|
|
} |
818
|
|
|
|
|
|
|
|
819
|
19
|
|
|
|
|
35
|
($lmod, $lvar, $lval) = ($mod, $var, $val); |
820
|
19
|
|
|
|
|
67
|
NEXT: |
821
|
|
|
|
|
|
|
$a = $b+length($linefeed); |
822
|
|
|
|
|
|
|
} |
823
|
|
|
|
|
|
|
|
824
|
16
|
50
|
|
|
|
33
|
return (0, "Method is missing.") unless ($mc); |
825
|
|
|
|
|
|
|
|
826
|
16
|
|
|
|
|
34
|
$d = substr($d, $a); |
827
|
|
|
|
|
|
|
|
828
|
16
|
|
|
|
|
67
|
return ($mc, $d, $vars); |
829
|
|
|
|
|
|
|
} |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
sub make_header { |
832
|
48
|
|
|
48
|
0
|
83
|
my ($mod, $key, $val) = @_; |
833
|
48
|
|
|
|
|
62
|
my $m; |
834
|
|
|
|
|
|
|
|
835
|
48
|
50
|
|
|
|
120
|
unless (defined($val)) { |
|
|
100
|
|
|
|
|
|
836
|
0
|
|
|
|
|
0
|
$m = ''; |
837
|
|
|
|
|
|
|
} elsif (ref $val eq 'ARRAY') { |
838
|
4
|
|
|
|
|
14
|
$m = "\t".join("\n$mod\t", @$val); |
839
|
|
|
|
|
|
|
} else { |
840
|
44
|
|
|
|
|
68
|
$val =~ s/\n/\n\t/g; |
841
|
44
|
|
|
|
|
71
|
$m = "\t$val"; |
842
|
|
|
|
|
|
|
} |
843
|
48
|
|
|
|
|
186
|
return "$mod$key$m\n"; |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
sub make_mmp { |
847
|
5
|
|
|
5
|
|
8257
|
use bytes; |
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
22
|
|
848
|
|
|
|
|
|
|
# $state is an object implementing out-state and state.. blarg |
849
|
22
|
|
|
22
|
0
|
36
|
my ($vars, $data, $state) = @_; |
850
|
22
|
|
|
|
|
28
|
my $m; |
851
|
|
|
|
|
|
|
|
852
|
22
|
50
|
|
|
|
121
|
if (!exists $vars->{'_length'}) { |
|
|
0
|
|
|
|
|
|
853
|
22
|
50
|
33
|
|
|
261
|
$vars->{'_length'} = length($data) |
|
|
|
33
|
|
|
|
|
854
|
|
|
|
|
|
|
if ($data =~ /^.\n/ || index($data, "\n.\n") != -1 || |
855
|
|
|
|
|
|
|
index($data, "\r\n.\r\n") != -1); |
856
|
|
|
|
|
|
|
} elsif (!defined($vars->{'_length'})) { |
857
|
0
|
|
|
|
|
0
|
$vars->{'_length'} = length($data); |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# we dont need to sort anymore. _count is a mmp-var. CHANGE THAT TODO |
861
|
22
|
|
|
|
|
107
|
foreach (sort keys %$vars) { |
862
|
58
|
|
|
|
|
102
|
my $mod = substr($_, 0, 1); |
863
|
58
|
|
|
|
|
68
|
my $var = $_; |
864
|
|
|
|
|
|
|
|
865
|
58
|
50
|
|
|
|
109
|
if ($mod ne '_') { |
866
|
0
|
|
|
|
|
0
|
$var = substr($_, 1); |
867
|
58
|
|
|
|
|
80
|
} else { $mod = ':'; } |
868
|
|
|
|
|
|
|
|
869
|
58
|
100
|
|
|
|
105
|
$m .= make_header($mod, $var, $vars->{$_}) if ISMMPVAR($var); |
870
|
|
|
|
|
|
|
=state |
871
|
|
|
|
|
|
|
if (ISMMPVAR($var) && |
872
|
|
|
|
|
|
|
(!$state || $state->outstate($mod, $var, $vars->{$_}))); |
873
|
|
|
|
|
|
|
=cut |
874
|
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
=state |
876
|
|
|
|
|
|
|
if ($state) { |
877
|
|
|
|
|
|
|
my $v = $state->state(); |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
foreach (keys %$v) { |
880
|
|
|
|
|
|
|
$m .= make_header(':', $_, $v->{$_}); |
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
} |
883
|
|
|
|
|
|
|
=cut |
884
|
|
|
|
|
|
|
|
885
|
22
|
100
|
|
|
|
51
|
if (!$data) { |
886
|
2
|
|
|
|
|
5
|
$m .= ".\n"; |
887
|
|
|
|
|
|
|
} else { |
888
|
20
|
|
|
|
|
42
|
$m .= "\n$data\n.\n"; |
889
|
|
|
|
|
|
|
} |
890
|
22
|
|
|
|
|
74
|
return $m; |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
# make_psyc ( mc, data, vars) |
894
|
|
|
|
|
|
|
sub make_psyc { |
895
|
16
|
|
|
16
|
0
|
38
|
my ($mc, $data, $vars, $state, $target, $iscontext) = @_; |
896
|
16
|
|
|
|
|
21
|
my $m = ""; |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
# we dont need to sort anymore. _count is a mmp-var. CHANGE THAT TODO |
899
|
16
|
|
|
|
|
62
|
foreach (sort keys %$vars) { |
900
|
3
|
|
|
|
|
9
|
my $mod = substr($_, 0, 1); |
901
|
3
|
|
|
|
|
5
|
my $var = $_; |
902
|
|
|
|
|
|
|
|
903
|
3
|
50
|
|
|
|
10
|
next if ($var =~ /^_INTERNAL_/); |
904
|
|
|
|
|
|
|
|
905
|
3
|
50
|
|
|
|
10
|
if ($mod ne '_') { |
906
|
0
|
|
|
|
|
0
|
$var = substr($_, 1); |
907
|
3
|
|
|
|
|
8
|
} else { $mod = ':'; } |
908
|
|
|
|
|
|
|
|
909
|
3
|
50
|
|
|
|
11
|
$m .= make_header($mod, $var, $vars->{$var}) unless ISMMPVAR($var); |
910
|
|
|
|
|
|
|
=state |
911
|
|
|
|
|
|
|
if (!ISMMPVAR($var) && |
912
|
|
|
|
|
|
|
(!$state || $state->outstate($mod, $var, $vars->{$var}, $target, |
913
|
|
|
|
|
|
|
$iscontext))); |
914
|
|
|
|
|
|
|
=cut |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
=state |
917
|
|
|
|
|
|
|
if ($state) { |
918
|
|
|
|
|
|
|
my $v = $state->state($target, $iscontext); |
919
|
|
|
|
|
|
|
|
920
|
|
|
|
|
|
|
foreach (keys %$v) { |
921
|
|
|
|
|
|
|
$m .= make_header(':', $_, $v->{$_}); |
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
} |
924
|
|
|
|
|
|
|
=cut |
925
|
|
|
|
|
|
|
|
926
|
16
|
|
|
|
|
29
|
$m .= $mc; |
927
|
16
|
50
|
33
|
|
|
117
|
$m .= "\n" if ($m && $data); |
928
|
16
|
|
50
|
|
|
83
|
return $m.($data || ''); |
929
|
|
|
|
|
|
|
} |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
sub _augment { |
932
|
0
|
|
|
0
|
|
0
|
my ($vars, $key, $value) = @_; |
933
|
|
|
|
|
|
|
|
934
|
0
|
0
|
|
|
|
0
|
if (ref $value eq 'ARRAY') { |
935
|
|
|
|
|
|
|
# TODO .. |
936
|
0
|
0
|
|
|
|
0
|
map { _augment($vars, $key, $_) unless (ref $_) } @$value; |
|
0
|
|
|
|
|
0
|
|
937
|
0
|
|
|
|
|
0
|
return 1; |
938
|
|
|
|
|
|
|
} |
939
|
|
|
|
|
|
|
|
940
|
0
|
0
|
|
|
|
0
|
unless (exists $vars->{$key}) { |
|
|
0
|
|
|
|
|
|
941
|
0
|
|
|
|
|
0
|
$vars->{$key} = [ $value ]; |
942
|
|
|
|
|
|
|
} elsif (ref $vars->{$key} ne 'ARRAY') { |
943
|
0
|
|
|
|
|
0
|
$vars->{$key} = [ $vars->{$key}, $value ]; |
944
|
|
|
|
|
|
|
} else { |
945
|
0
|
|
|
|
|
0
|
push(@{$vars->{$key}}, $value); |
|
0
|
|
|
|
|
0
|
|
946
|
|
|
|
|
|
|
} |
947
|
0
|
|
|
|
|
0
|
return 1; |
948
|
|
|
|
|
|
|
} |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
sub _diminish { |
951
|
0
|
|
|
0
|
|
0
|
my ($vars, $key, $value) = @_; |
952
|
|
|
|
|
|
|
|
953
|
0
|
0
|
|
|
|
0
|
return if (not exists $vars->{$key}); |
954
|
|
|
|
|
|
|
|
955
|
0
|
0
|
|
|
|
0
|
if (ref $vars->{$key} ne 'ARRAY') { |
956
|
0
|
0
|
|
|
|
0
|
delete $vars->{$key} if ($vars->{$key} eq $value); |
957
|
|
|
|
|
|
|
} else { |
958
|
0
|
|
|
|
|
0
|
@{$vars->{$key}} = grep { $_ ne $value } @{$vars->{$key}}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
# TODO rename that to make_msg. |
963
|
|
|
|
|
|
|
# replaced by make_psyc |
964
|
|
|
|
|
|
|
sub makeMSG { |
965
|
0
|
|
|
0
|
0
|
0
|
my ($mc, $data) = @_; |
966
|
0
|
|
0
|
|
|
0
|
my $vars = $_[2] || {}; |
967
|
|
|
|
|
|
|
|
968
|
0
|
0
|
|
|
|
0
|
return ($vars, make_psyc($mc, $data, $vars)) if wantarray; |
969
|
|
|
|
|
|
|
|
970
|
0
|
|
|
|
|
0
|
return make_mmp($vars, make_psyc($mc, $data, $vars)); |
971
|
|
|
|
|
|
|
} |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
sub parse_uniform { |
974
|
71
|
|
|
71
|
0
|
19260
|
my $arg = shift; |
975
|
|
|
|
|
|
|
|
976
|
71
|
100
|
|
|
|
360
|
if (exists $URLS{$arg}) { |
977
|
45
|
|
|
|
|
90
|
my $t = $URLS{$arg}; |
978
|
45
|
100
|
|
|
|
229
|
return $t unless wantarray; |
979
|
|
|
|
|
|
|
|
980
|
6
|
|
|
|
|
32
|
return ( $t->{'user'}, $t->{'host'}, $t->{'port'}, $t->{'transport'}, |
981
|
|
|
|
|
|
|
$t->{'object'} ); |
982
|
|
|
|
|
|
|
} |
983
|
26
|
|
|
|
|
35
|
local $_; |
984
|
26
|
|
|
|
|
45
|
$_ = $arg; |
985
|
|
|
|
|
|
|
|
986
|
26
|
|
|
|
|
39
|
my ($scheme, $user, $host, $port, $transport, $object); |
987
|
|
|
|
|
|
|
|
988
|
26
|
100
|
|
|
|
194
|
return $URLS{$arg} = 0 unless s/^(\w+)\://; |
989
|
25
|
|
|
|
|
65
|
$scheme = $1; |
990
|
|
|
|
|
|
|
|
991
|
25
|
100
|
66
|
|
|
84
|
if ($scheme eq 'psyc' || $scheme eq 'irc') { |
992
|
22
|
50
|
|
|
|
113
|
return $URLS{$arg} = 0 unless s/^\G\/\///; |
993
|
|
|
|
|
|
|
} |
994
|
|
|
|
|
|
|
|
995
|
25
|
100
|
33
|
|
|
208
|
if (s/([\w\-+]+)\@//) { |
|
|
50
|
|
|
|
|
|
996
|
5
|
|
|
|
|
11
|
$user = $1; |
997
|
|
|
|
|
|
|
} elsif ($scheme eq 'mailto' || $scheme eq 'xmpp') { |
998
|
|
|
|
|
|
|
# need a users.. |
999
|
0
|
|
|
|
|
0
|
return $URLS{$arg} = 0; |
1000
|
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
# [\w-.] may be to restrictive. is it?? |
1003
|
25
|
100
|
|
|
|
160
|
return $URLS{$arg} = 0 unless s/^([\w\-.]*)(?:\:\-?(\d*)([cd]?)|)(?:\z|\/)//; |
1004
|
24
|
100
|
|
|
|
150
|
($host, $port, $transport) = ($1, $2 ? int($2) : '', $3); |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
# is there any other protocol supporting transports?? am i wrong here? |
1007
|
24
|
100
|
100
|
|
|
5922
|
return $URLS{$arg} = 0 if ($transport && $scheme ne 'psyc'); |
1008
|
|
|
|
|
|
|
|
1009
|
23
|
100
|
|
|
|
92
|
goto EOU unless length($_); |
1010
|
|
|
|
|
|
|
|
1011
|
3
|
50
|
|
|
|
10
|
if ($scheme eq 'mailto') { |
1012
|
|
|
|
|
|
|
# mailto should not have a path. what do we do then? |
1013
|
0
|
|
|
|
|
0
|
return $URLS{$arg} = 0; |
1014
|
|
|
|
|
|
|
} |
1015
|
|
|
|
|
|
|
|
1016
|
3
|
50
|
33
|
|
|
26
|
return $URLS{$arg} = 0 unless ($scheme ne 'psyc' || /^[@~][\w\-]+$/); |
1017
|
3
|
|
|
|
|
7
|
$object = $_; |
1018
|
|
|
|
|
|
|
|
1019
|
23
|
100
|
50
|
|
|
215
|
EOU: |
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
1020
|
|
|
|
|
|
|
return ($user||'', $host||'', $port, $transport||'', $object||'') |
1021
|
|
|
|
|
|
|
if wantarray; |
1022
|
9
|
|
100
|
|
|
173
|
$URLS{$arg} = { |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
1023
|
|
|
|
|
|
|
unl => $arg, |
1024
|
|
|
|
|
|
|
host => $host||'', |
1025
|
|
|
|
|
|
|
port => $port, |
1026
|
|
|
|
|
|
|
transport => $transport||'', |
1027
|
|
|
|
|
|
|
object => $object||'', |
1028
|
|
|
|
|
|
|
user => $user||'', |
1029
|
|
|
|
|
|
|
scheme => $scheme||'', |
1030
|
|
|
|
|
|
|
}; |
1031
|
|
|
|
|
|
|
# maybe a cache is the best solution we got since tied scalars are not |
1032
|
|
|
|
|
|
|
# what I would like them to be. |
1033
|
9
|
|
|
|
|
37
|
return $URLS{$arg}; |
1034
|
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
# TODO i would like to get rid of croak. |
1037
|
|
|
|
|
|
|
sub make_uniform { |
1038
|
2
|
|
|
2
|
1
|
6
|
my ($user, $host, $port, $type, $object) = @_; |
1039
|
2
|
50
|
33
|
|
|
23
|
$port = '' if !$port || $port == PSYC_PORT; |
1040
|
2
|
50
|
|
|
|
50
|
unless ($object) { |
1041
|
2
|
|
|
|
|
5
|
$object = ''; |
1042
|
|
|
|
|
|
|
} else { |
1043
|
0
|
|
|
|
|
0
|
$object = '/'.$object; |
1044
|
|
|
|
|
|
|
} |
1045
|
|
|
|
|
|
|
|
1046
|
2
|
50
|
|
|
|
10
|
$type = '' unless $type; |
1047
|
2
|
50
|
|
|
|
7
|
unless ($host) { |
1048
|
|
|
|
|
|
|
# we could check here for $Net::PSYC::Client::SERVER_HOST |
1049
|
0
|
|
|
|
|
0
|
W0('well-known UNIs not standardized yet'); |
1050
|
0
|
|
|
|
|
0
|
return 0; |
1051
|
|
|
|
|
|
|
} |
1052
|
2
|
50
|
|
|
|
11
|
$host = "$user\@$host" if $user; |
1053
|
2
|
50
|
33
|
|
|
10
|
return "psyc://$host$object" unless $port || $type; |
1054
|
2
|
|
|
|
|
13
|
return "psyc://$host:$port$type$object"; |
1055
|
|
|
|
|
|
|
} |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
################################################################ |
1058
|
|
|
|
|
|
|
# Functions needed to be downward compatible to Net::PSYC 0.7 |
1059
|
|
|
|
|
|
|
# Not entirely clear which of these we can really call obsolete |
1060
|
|
|
|
|
|
|
# |
1061
|
|
|
|
|
|
|
sub dirty_wait { |
1062
|
0
|
|
|
0
|
0
|
|
return Net::PSYC::Event::can_read(@_); |
1063
|
|
|
|
|
|
|
} |
1064
|
|
|
|
|
|
|
# |
1065
|
|
|
|
|
|
|
sub dirty_add { |
1066
|
0
|
|
|
0
|
0
|
|
Net::PSYC::Event::add($_[0], 'r', sub { 1 }); |
|
0
|
|
|
0
|
|
|
|
1067
|
|
|
|
|
|
|
} |
1068
|
0
|
|
|
0
|
0
|
|
sub dirty_remove { Net::PSYC::Event::remove(@_); } |
1069
|
|
|
|
|
|
|
# |
1070
|
|
|
|
|
|
|
# alright, so this should definitely not be used as it will not |
1071
|
|
|
|
|
|
|
# be able to handle multiple and incomplete packets in one read operation. |
1072
|
|
|
|
|
|
|
sub dirty_getmsg { |
1073
|
0
|
|
|
0
|
0
|
|
my $key; |
1074
|
0
|
|
|
|
|
|
my @readable = Net::PSYC::Event::can_read(@_); |
1075
|
0
|
|
|
|
|
|
my %sockets = %{&Net::PSYC::Event::PSYC_SOCKETS()}; |
|
0
|
|
|
|
|
|
|
1076
|
0
|
|
|
|
|
|
my ($mc, $data, $vars); |
1077
|
0
|
|
|
|
|
|
SOCKET: foreach (@readable) { |
1078
|
0
|
|
|
|
|
|
$key = fileno($_); |
1079
|
0
|
0
|
|
|
|
|
if (exists $sockets{$key}) { # found a readable psyc-obj |
1080
|
0
|
0
|
|
|
|
|
unless (defined($sockets{$key}->read())) { |
1081
|
0
|
|
|
|
|
|
Net::PSYC::shutdown($sockets{$key}); |
1082
|
0
|
|
|
|
|
|
W2('Lost connection to %s:%s.', |
1083
|
|
|
|
|
|
|
$sockets{$key}->{'R_IP'}, $sockets{$key}->{'R_PORT'}); |
1084
|
0
|
|
|
|
|
|
next SOCKET; |
1085
|
|
|
|
|
|
|
} |
1086
|
0
|
|
|
|
|
|
while (1) { |
1087
|
0
|
|
|
|
|
|
my ($MMPvars, $MMPdata) = $sockets{$key}->recv(); |
1088
|
0
|
0
|
|
|
|
|
next SOCKET if (!defined($MMPdata)); |
1089
|
|
|
|
|
|
|
|
1090
|
0
|
|
|
|
|
|
($mc, $data, $vars) = parse_psyc($MMPdata, $sockets{$key}->{'LF'}); |
1091
|
0
|
0
|
|
|
|
|
last if($mc); # ignore empty messages.. |
1092
|
|
|
|
|
|
|
} |
1093
|
0
|
|
|
|
|
|
W1('\n=== dirty_getmsg %s\n%s\n%s\n', '=' x 67, $data, '=' x 79); |
1094
|
0
|
0
|
|
|
|
|
my ($port, $ip) = sockaddr_in($sockets{$key}->{'LAST_RECV'}) |
1095
|
|
|
|
|
|
|
if $sockets{$key}->{'LAST_RECV'}; |
1096
|
0
|
0
|
|
|
|
|
$ip = inet_ntoa($ip) if $ip; |
1097
|
0
|
|
|
|
|
|
return ('', $ip, $port, $mc, $data, %$vars); |
1098
|
0
|
|
|
|
|
|
return ('', '', 0, $mc, $data, %$vars); |
1099
|
|
|
|
|
|
|
} |
1100
|
|
|
|
|
|
|
} |
1101
|
0
|
|
|
|
|
|
return ('NO PSYC-SOCKET READABLE!', '', 0, '', '', ()); |
1102
|
|
|
|
|
|
|
} |
1103
|
|
|
|
|
|
|
# |
1104
|
|
|
|
|
|
|
################################################################ |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
1; |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
# dirty_add, dirty_remove and dirty_wait implement a pragmatic IO::Select wrapper for applications that do not need an event loop. |
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
__END__ |