File Coverage

lib/Asterisk/Manager.pm
Criterion Covered Total %
statement 29 180 16.1
branch 0 64 0.0
condition 1 16 6.2
subroutine 6 29 20.6
pod 0 23 0.0
total 36 312 11.5


line stmt bran cond sub pod time code
1             package Asterisk::Manager;
2              
3             require 5.004;
4              
5 1     1   612 use Asterisk;
  1         1  
  1         21  
6 1     1   437 use IO::Socket;
  1         14391  
  1         6  
7 1     1   340 use Digest::MD5;
  1         2  
  1         28  
8              
9 1     1   3 use strict;
  1         2  
  1         16  
10 1     1   3 use warnings;
  1         1  
  1         1269  
11              
12             =head1 NAME
13              
14             Asterisk::Manager - Asterisk Manager Interface
15              
16             =head1 SYNOPSIS
17              
18             use Asterisk::Manager;
19              
20             my $astman = new Asterisk::Manager;
21              
22             $astman->user('username');
23              
24             $astman->secret('test');
25              
26             $astman->host('localhost');
27              
28             $astman->connect || die "Could not connect to " . $astman->host . "!\n";
29              
30             $astman->disconnect;
31              
32             =head1 DESCRIPTION
33              
34             This module provides a simple interface to the asterisk manager interface.
35              
36             =cut
37              
38             my $EOL = "\r\n";
39             my $BLANK = $EOL x 2;
40              
41             my $VERSION = '0.01';
42              
43 0     0 0 0 sub version { $VERSION; }
44              
45             sub new {
46 1     1 0 626 my ($class, %args) = @_;
47              
48 1         2 my $self = {};
49 1         2 $self->{_CONNFD} = undef;
50 1         1 $self->{_PROTOVERS} = undef;
51 1         1 $self->{_ERRORSTR} = undef;
52 1         2 $self->{_HOST} = 'localhost';
53 1         1 $self->{_PORT} = 5038;
54 1         1 $self->{_USER} = undef;
55 1         1 $self->{_SECRET} = undef;
56 1         1 $self->{_EVENTCB} = {};
57 1         2 $self->{_DEBUG} = 0;
58 1         1 $self->{_CONNECTED} = 0;
59 1   33     7 bless $self, ref $class || $class;
60 1         2 return $self;
61             }
62              
63       0     sub DESTROY { }
64              
65             sub user {
66 0     0 0   my ($self, $user) = @_;
67              
68 0 0         if ($user) {
69 0           $self->{_USER} = $user;
70             }
71              
72 0           return $self->{_USER};
73             }
74              
75             sub secret {
76 0     0 0   my ($self, $secret) = @_;
77              
78 0 0         if ($secret) {
79 0           $self->{_SECRET} = $secret;
80             }
81              
82 0           return $self->{_SECRET};
83             }
84              
85             sub host {
86 0     0 0   my ($self, $host) = @_;
87              
88 0 0         if ($host) {
89 0           $self->{_HOST} = $host;
90             }
91              
92 0           return $self->{_HOST};
93             }
94              
95             sub port {
96 0     0 0   my ($self, $port) = @_;
97              
98 0 0         if ($port) {
99 0           $self->{_PORT} = $port;
100             }
101              
102 0           return $self->{_PORT};
103             }
104              
105             sub connected {
106 0     0 0   my ($self, $connected) = @_;
107              
108 0 0         if (defined($connected)) {
109 0           $self->{_CONNECTED} = $connected;
110             }
111              
112 0           return $self->{_CONNECTED};
113             }
114              
115             sub error {
116 0     0 0   my ($self, $error) = @_;
117              
118 0 0         if ($error) {
119 0           $self->{_ERRORSTR} = $error;
120             }
121              
122 0           return $self->{_ERRORSTR};
123             }
124              
125             sub debug {
126 0     0 0   my ($self, $debug) = @_;
127              
128 0 0         if ($debug) {
129 0           $self->{_DEBUG} = $debug;
130             }
131              
132 0           return $self->{_DEBUG};
133             }
134              
135             sub connfd {
136 0     0 0   my ($self, $connfd) = @_;
137              
138 0 0         if ($connfd) {
139 0           $self->{_CONNFD} = $connfd;
140             }
141              
142 0           return $self->{_CONNFD};
143             }
144              
145             sub read_response {
146 0     0 0   my ($self, $connfd) = @_;
147              
148 0           my @response;
149              
150 0 0         if (!$connfd) {
151 0           $connfd = $self->connfd;
152             }
153              
154 0           while (my $line = <$connfd>) {
155 0 0         last if ($line eq $EOL);
156              
157 0 0         if (wantarray) {
158 0           $line =~ s/$EOL//g;
159 0 0         push(@response, $line) if $line;
160             } else {
161 0           $response[0] .= $line;
162             }
163              
164             }
165              
166 0 0         return wantarray ? @response : $response[0];
167             }
168              
169             sub connect {
170 0     0 0   my ($self) = @_;
171              
172 0           my $host = $self->host;
173 0           my $port = $self->port;
174 0           my $user = $self->user;
175 0           my $secret = $self->secret;
176 0           my %resp;
177              
178 0           my $conn = new IO::Socket::INET( Proto => 'tcp',
179             PeerAddr => $host,
180             PeerPort => $port
181             );
182 0 0         if (!$conn) {
183 0           $self->error("Connection refused ($host:$port)\n");
184 0           return undef;
185             }
186              
187 0           $conn->autoflush(1);
188              
189 0           my $input = <$conn>;
190 0           $input =~ s/$EOL//g;
191              
192 0           my ($manager, $version) = split('/', $input);
193              
194 0 0         if ($manager !~ /Asterisk Call Manager/) {
195 0           return $self->error("Unknown Protocol\n");
196             }
197              
198 0           $self->{_PROTOVERS} = $version;
199 0           $self->connfd($conn);
200              
201             # check if the remote host supports MD5 Challenge authentication
202 0           my %authresp = $self->sendcommand( Action => 'Challenge',
203             AuthType => 'MD5'
204             );
205              
206 0 0         if (($authresp{Response} eq 'Success')) {
207             # do md5 login
208 0           my $md5 = new Digest::MD5;
209 0           $md5->add($authresp{Challenge});
210 0           $md5->add($secret);
211 0           my $digest = $md5->hexdigest;
212 0           %resp = $self->sendcommand( Action => 'Login',
213             AuthType => 'MD5',
214             Username => $user,
215             Key => $digest
216             );
217             } else {
218             # do plain text login
219 0           %resp = $self->sendcommand( Action => 'Login',
220             Username => $user,
221             Secret => $secret
222             );
223              
224             }
225              
226 0 0 0       if ( ($resp{Response} ne 'Success') && ($resp{Message} ne 'Authentication accepted') ) {
227 0           $self->error("Authentication failed for user $user\n");
228 0           return undef;
229             }
230              
231 0           $self->connected(1);
232              
233 0           return $conn;
234             }
235              
236             sub astman_h2s {
237 0     0 0   my ($self, %thash) = @_;
238              
239 0           my $tstring = '';
240              
241 0           foreach my $key (keys %thash) {
242 0           $tstring .= $key . ': ' . $thash{$key} . ${EOL};
243             }
244              
245 0           return $tstring;
246             }
247              
248             sub astman_s2h {
249 0     0 0   my ($self, $tstring) = @_;
250              
251 0           my %thash;
252              
253 0           foreach my $line (split(/$EOL/, $tstring)) {
254 0 0         if ($line =~ /(\w*):\s*(\w*)/) {
255 0           $thash{$1} = $2;
256             }
257             }
258              
259 0           return %thash;
260             }
261              
262             #$want is how you want the data returned
263             #$want = 0 (default) returns the results in a hash
264             #$want = 1 returns the results in a large string
265             #$want = 2 returns the results in an array
266             sub sendcommand {
267 0     0 0   my ($self, @rest) = @_;
268 0           my (%command, $want);
269              
270 0 0         if ((scalar(@rest) % 2) == 1) {
271 0           $want = pop @rest;
272             } else {
273 0           $want = 0;
274             }
275 0           %command = @rest;
276            
277 0   0       my $conn = $self->connfd || return;
278 0           my $cstring = $self->astman_h2s(%command);
279              
280 0           $conn->send("$cstring$EOL");
281              
282 0 0         if ($want == 1) {
283 0           my $response = $self->read_response($conn);
284 0           return $response;
285             }
286              
287 0           my @resp = $self->read_response($conn);
288              
289 0 0         if ($want == 2) {
290 0           return @resp;
291             } else {
292 0           return map { splitresult($_) } @resp;
  0            
293             }
294             }
295              
296             sub setcallback {
297 0     0 0   my ($self, $event, $function) = @_;
298              
299 0 0 0       if (defined($function) && ref($function) eq 'CODE') {
300 0           $self->{_EVENTCB}{$event} = $function;
301             }
302             }
303              
304             sub eventcallback {
305 0     0 0   my ($self, %resp) = @_;
306              
307 0           my $callback;
308 0           my $event = $resp{Event};
309              
310 0 0         return if (!$event);
311              
312 0 0         if (defined($self->{_EVENTCB}{$event})) {
    0          
313 0           $callback = $self->{_EVENTCB}{$event};
314             } elsif (defined($self->{_EVENTCB}{DEFAULT})) {
315 0           $callback = $self->{_EVENTCB}{DEFAULT};
316             } else {
317 0           return;
318             }
319              
320 0           return &{$callback}(%resp);
  0            
321             }
322              
323             sub eventloop {
324 0     0 0   my ($self) = @_;
325              
326 0           while (1) {
327 0           $self->handleevent;
328             }
329             }
330              
331             sub handleevent {
332 0     0 0   my ($self) = @_;
333              
334 0           my %resp = map { splitresult($_); } $self->read_response;
  0            
335 0           $self->eventcallback(%resp);
336              
337 0           return %resp;
338             }
339              
340             sub action {
341 0     0 0   my ($self, $command, $wanthash) = @_;
342              
343 0 0         return if (!$command);
344              
345 0   0       my $conn = $self->connfd || return;
346              
347 0           print $conn "Action: $command" . $BLANK;
348 0           my @resp = $self->read_response($conn);
349              
350 0 0         if ($wanthash) {
    0          
351 0           return map { splitresult($_) } @resp;
  0            
352             } elsif (wantarray) {
353 0           return @resp;
354             } else {
355 0           return $resp[0];
356             }
357             }
358              
359             sub command {
360 0     0 0   my ($self, $command) = @_;
361              
362 0 0         return if (!$command);
363              
364 0           return $self->sendcommand('Action' => 'Command',
365             'Command' => $command, 1 );
366             }
367              
368             sub disconnect {
369 0     0 0   my ($self) = @_;
370              
371 0           my $conn = $self->connfd;
372              
373 0           my %resp = $self->sendcommand('Action' => 'Logoff');
374              
375              
376 0 0 0       if (defined ($resp{Response}) && $resp{Response} eq 'Goodbye') {
377 0           $self->{_CONNFD} = undef;
378 0           $self->connected(0);
379 0           return 1;
380             }
381              
382 0           return 0;
383             }
384              
385             sub splitresult {
386 0     0 0   my ($res) = @_;
387 0           my ($key, $val) = ('', '');
388              
389 0           $res =~ /^([^:]+):\ {0,1}([^\ ].*)$/;
390 0 0         $key = $1 if defined($1);
391 0 0         $val = $2 if defined($2);
392              
393 0           return ($key, $val);
394             }
395              
396             1;