source: perl/modules/AIM/lib/Net/OSCAR/Callbacks/4/incoming_IM.pm @ 7a1c90d

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