File Coverage

blib/lib/Net/OSCAR/Callbacks/4/incoming_IM.pm
Criterion Covered Total %
statement 13 13 100.0
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 18 100.0


line stmt bran cond sub pod time code
1             package Net::OSCAR::Callbacks;
2             BEGIN {
3 1     1   21 $Net::OSCAR::Callbacks::VERSION = '1.928';
4             }
5 1     1   6 use strict;
  1         3  
  1         28  
6 1     1   5 use warnings;
  1         3  
  1         34  
7 1     1   4 use vars qw($connection $snac $conntype $family $subtype $data $reqid $reqdata $session $protobit %data);
  1         2  
  1         101  
8 1     1   5 use Socket qw(inet_ntoa);
  1         3  
  1         1765  
9             sub {
10              
11             my $sender = Net::OSCAR::Screenname->new(\$data{screenname});
12             my $sender_info = $session->{userinfo}->{$sender} ||= {};
13              
14             if($data{channel} == 1) { # Regular IM
15             %data = protoparse($session, "standard_IM_footer")->unpack($data{message_body});
16              
17             # Typing status
18             my $typing_status = 0;
19             if(exists($data{supports_typing_status})) {
20             $sender_info->{typing_status} = 1;
21             } else {
22             delete $sender_info->{typing_status};
23             }
24              
25              
26             # Buddy icon
27             my $new_icon = 0;
28             if(exists($data{icon_data}->{icon_length}) and $session->{capabilities}->{buddy_icons}) {
29             if(!exists($sender_info->{icon_timestamp})
30             or $data{icon_data}->{icon_timestamp} > $sender_info->{icon_timestamp}
31             or $data{icon_data}->{icon_checksum} != $sender_info->{icon_checksum}
32             ) {
33             $new_icon = 1;
34             }
35             }
36              
37             $sender_info->{$_} = $data{icon_data}->{$_} foreach keys %{$data{icon_data}};
38              
39             $session->callback_new_buddy_icon($sender, $sender_info) if $new_icon;
40              
41              
42             # Okay, finally we're done with silly processing of embedded flags
43             $session->callback_im_in($sender, $data{message}, exists($data{is_automatic}) ? 1 : 0);
44              
45             } elsif($data{channel} == 2) {
46             %data = protoparse($session, "rendezvous_IM")->unpack($data{message_body});
47             my $type = OSCAR_CAPS_INVERSE()->{$data{capability}};
48             $session->{rv_proposals}->{$data{cookie}} ||= {};
49             my $rv = $session->{rv_proposals}->{$data{cookie}};
50              
51             if($data{status} eq "cancel") {
52             $connection->log_print(OSCAR_DBG_DEBUG, "Peer rejected proposal.");
53             $session->callback_rendezvous_reject($data{cookie});
54             $session->delconn($rv->{connection}) if $rv->{connection};
55             delete $session->{rv_proposals}->{$data{cookie}};
56             return;
57             } elsif($data{status} eq "accept") {
58             $connection->log_print(OSCAR_DBG_DEBUG, "Peer accepted proposal.");
59             $rv->{accepted} = 1;
60              
61             delete $session->{rv_proposals}->{$data{cookie}};
62             $session->callback_rendezvous_accept($data{cookie});
63             return;
64             }
65              
66             if(!$type) {
67             $connection->log_print_cond(OSCAR_DBG_INFO, sub { "Unknown rendezvous type: ", hexdump($data{capability}) });
68             $session->rendezvous_reject($data{cookie});
69             return;
70             }
71              
72             if(!$rv->{cookie}) {
73             $rv->{type} = $type;
74             $rv->{sender} = $sender;
75             $rv->{recipient} = $session->{screenname};
76             $rv->{cookie} = $data{cookie};
77             } elsif($rv->{peer} ne $sender) {
78             $connection->log_printf(OSCAR_DBG_WARN, "$sender tried to send a rendezvous which was previously sent by %s; discarding.", $rv->{peer});
79             return;
80             }
81              
82             if($type eq "chat") {
83             my %svcdata = protoparse($session, "chat_invite_rendezvous_data")->unpack($data{svcdata});
84              
85             # Ignore invites for chats that we're already in
86             if(not grep { $_->{url} eq $svcdata{url} }
87             grep { $_->{conntype} == CONNTYPE_CHAT }
88             @{$session->{connections}}
89             ) {
90             # Extract chat ID from char URL
91             $rv->{chat_url} = $svcdata{url};
92             $svcdata{url} =~ /-.*?-(.*?)(\0*)$/;
93             my $chat = $1;
94             $chat =~ s/%([0-9A-Z]{1,2})/chr(hex($1))/eig;
95             $rv->{name} = $chat;
96             $rv->{exchange} = $svcdata{exchange};
97              
98             $session->callback_chat_invite($sender, $data{invitation_msg}, $chat, $svcdata{url});
99             }
100             } elsif($type eq "filexfer") {
101             # If proposal is being revised, no svcdata will be present.
102             my %svcdata;
103             if($data{svcdata}) {
104             %svcdata = protoparse($session, "file_transfer_rendezvous_data")->unpack($data{svcdata});
105              
106             $rv->{direction} = "receive";
107             $rv->{accepted} = 0;
108             $rv->{filenames} = $svcdata{files};
109             $rv->{total_size} = $svcdata{size};
110             $rv->{file_count} = $svcdata{file_count};
111             $rv->{using_proxy} = 0;
112             $rv->{tried_proxy} = 0;
113             $rv->{tried_listen} = 0;
114             $rv->{tried_connect} = 0;
115             } elsif($rv->{connection}) {
116             $session->delconn($rv->{connection});
117             delete $rv->{connection};
118             }
119              
120             $rv->{port} = $data{port};
121             $rv->{external_ip} = $data{client_external_ip} ? inet_ntoa(pack("N", $data{client_external_ip})) : "";
122             $rv->{ip} = $data{client_1_ip} ? inet_ntoa(pack("N", $data{client_1_ip})) : $rv->{external_ip};
123             $rv->{ft_state} = "unconnected";
124              
125             $connection->log_printf(OSCAR_DBG_DEBUG, "Got proposal %s for %s:%d (external %s)", hexdump($rv->{cookie}), $rv->{ip}, $rv->{port}, $rv->{external_ip});
126             } elsif($type eq "sendlist") {
127             my %svcdata = protoparse($session, "buddy_list_transfer_rendezvous_data")->unpack($data{svcdata});
128             delete $session->{rv_proposals}->{$data{cookie}};
129              
130             my $list = bltie();
131             foreach my $group (@{$svcdata{group}}) {
132             $list->{$group->{name}} = [];
133              
134             my $grouplist = $list->{$group->{name}};
135             foreach my $buddy (@{$group->{buddies}}) {
136             push @$grouplist, Net::OSCAR::Screenname->new(\$buddy->{name});
137             }
138             }
139              
140             $session->callback_buddylist_in($sender, $list);
141             } else {
142             $connection->log_print(OSCAR_DBG_INFO, "Unsupported rendezvous type '$type'");
143             $session->rendezvous_reject($data{cookie});
144             }
145             }
146              
147             };