File Coverage

blib/lib/Net/PSYC.pm
Criterion Covered Total %
statement 296 510 58.0
branch 146 356 41.0
condition 66 147 44.9
subroutine 34 51 66.6
pod 12 42 28.5
total 554 1106 50.0


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__