File Coverage

blib/lib/Telephony/Asterisk/AMI.pm
Criterion Covered Total %
statement 83 113 73.4
branch 30 48 62.5
condition 6 12 50.0
subroutine 13 13 100.0
pod 7 7 100.0
total 139 193 72.0


line stmt bran cond sub pod time code
1             #---------------------------------------------------------------------
2             package Telephony::Asterisk::AMI;
3             #
4             # Copyright 2015 Christopher J. Madsen
5             #
6             # Author: Christopher J. Madsen
7             # Created: 31 Oct 2015
8             #
9             # This program is free software; you can redistribute it and/or modify
10             # it under the same terms as Perl itself.
11             #
12             # This program is distributed in the hope that it will be useful,
13             # but WITHOUT ANY WARRANTY; without even the implied warranty of
14             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
15             # GNU General Public License or the Artistic License for more details.
16             #
17             # ABSTRACT: Simple Asterisk Manager Interface client
18             #---------------------------------------------------------------------
19              
20 2     2   53314 use 5.008;
  2         8  
21 2     2   13 use strict;
  2         4  
  2         50  
22 2     2   11 use warnings;
  2         4  
  2         64  
23              
24              
25 2     2   12 use Carp ();
  2         4  
  2         44  
26 2     2   2301 use IO::Socket::IP ();
  2         105280  
  2         1615  
27              
28             our $VERSION = '0.004';
29             # This file is part of Telephony-Asterisk-AMI 0.004 (November 28, 2015)
30              
31             my $EOL = "\r\n";
32              
33             #=====================================================================
34              
35              
36             sub new {
37 1     1 1 164 my $class = shift;
38 1 50       9 my $args = (@_ == 1) ? shift : { @_ };
39              
40             my $self = bless {
41             Debug_FH => ($args->{Debug_FH} || ($args->{Debug} ? *STDERR : undef)),
42             Event_Callback => $args->{Event_Callback},
43             Host => $args->{Host} || 'localhost',
44             Port => $args->{Port} || 5038,
45 1   33     31 ActionID => $args->{ActionID} || 1,
      50        
      50        
      50        
46             }, $class;
47              
48 1         4 for my $key (qw(Username Secret)) {
49 2 50       15 defined( $self->{$key} = $args->{$key} )
50             or Carp::croak("Required parameter '$key' not defined");
51             }
52              
53 1         5 $self;
54             } # end new
55             #---------------------------------------------------------------------
56              
57              
58             sub connect {
59 1     1 1 494 my $self = shift;
60              
61             # Open a socket to Asterisk.
62             # IO::Socket::IP->new reports error in $@
63 1         2 local $@;
64              
65             $self->{socket} = IO::Socket::IP->new(
66             Type => IO::Socket::IP::SOCK_STREAM(),
67             PeerHost => $self->{Host},
68             PeerService => $self->{Port},
69 1         14 );
70              
71 1 50       31 unless ($self->{socket}) {
72 0         0 $self->{error} = "Connection failed: $@";
73 0         0 return undef;
74             }
75              
76             # Verify that we've connected to Asterisk Call Manager
77 1         7 my $id = readline($self->{socket});
78              
79 1 50       7 unless (defined $id) {
80 0         0 $self->{error} = "Connection closed without input: $!";
81 0         0 undef $self->{socket};
82 0         0 return undef;
83             }
84              
85 1         3 chomp $id;
86 1 50       4 print { $self->{Debug_FH} } "<< $id\n" if $self->{Debug_FH};
  0         0  
87              
88 1 50       7 if ($id =~ m!^Asterisk Call Manager/(.+)!) {
89 1         6 $self->{protocol} = $1;
90             } else {
91 0         0 $self->{error} = "Unknown Protocol";
92 0         0 undef $self->{socket};
93 0         0 return undef;
94             }
95              
96             # Automatically log in using Username/Secret
97             my $response = $self->action({
98             Action => 'Login',
99             Username => $self->{Username},
100             Secret => $self->{Secret},
101 1         8 });
102              
103             # If login failed, set error
104 1 50       6 unless ($response->{Response} eq 'Success') {
105 0         0 $self->{error} = "Login failed: $response->{Message}";
106 0         0 undef $self->{socket};
107 0         0 return undef;
108             }
109              
110             # Login successful
111 1         7 1;
112             } # end connect
113             #---------------------------------------------------------------------
114              
115              
116             sub disconnect {
117 1     1 1 3 my $self = shift;
118              
119 1         4 my $response = $self->action({Action => 'Logoff'});
120              
121             # If logoff failed, set error
122 1 50       5 unless ($response->{Response} eq 'Goodbye') {
123 0         0 $self->{error} = "Logoff failed: $response->{Message}";
124 0         0 undef $self->{socket};
125 0         0 return undef;
126             }
127              
128 1 50       60 unless ($self->{socket}->close) {
129 0         0 $self->{error} = "Closing socket failed: $!";
130 0         0 undef $self->{socket};
131 0         0 return undef;
132             }
133              
134 1         15 undef $self->{socket};
135              
136             # Logoff successful
137 1         6 1;
138             } # end disconnect
139             #---------------------------------------------------------------------
140              
141              
142             sub action {
143 7     7 1 12 my $self = shift;
144              
145             # Send the request to Asterisk
146             my $id = $self->send_action(@_) or return {
147             Response => 'Error',
148             Message => $self->{error},
149 7 50       20 };
150              
151             # Read responses until we get the response to this action
152 7         13 while (1) {
153 9         18 my $response = $self->read_response;
154              
155             # If this is the response to the action we just sent,
156             # or there was an error, return it.
157 2     2   22 no warnings 'uninitialized';
  2         5  
  2         1953  
158 9 100 66     43 if (($response->{ActionID} eq $id) ||
159             ($response->{Response} eq 'Error')) {
160 7         46 return $response;
161             }
162              
163             # If there is an event callback, send it this event
164 2 50       11 if ($self->{Event_Callback}) {
165 0         0 $self->{Event_Callback}->($response);
166             }
167             } # end infinite loop waiting for response
168             } # end action
169             #---------------------------------------------------------------------
170              
171              
172             sub send_action {
173 7     7 1 8 my $self = shift;
174 7 100       26 my $act = (@_ == 1) ? shift : { @_ };
175              
176 7 50       19 Carp::croak("Required parameter 'Action' not defined") unless $act->{Action};
177              
178             # Check that the connection is open
179 7 50       19 unless ($self->{socket}) {
180 0         0 $self->{error} = "Not connected to Asterisk!";
181 0         0 return undef;
182             }
183              
184             # Assemble the message to send to Asterisk
185 7         10 my $id = $self->{ActionID}++;
186 7         16 my $message = "ActionID: $id$EOL";
187              
188 7         30 for my $key (sort keys %$act) {
189 14 100       29 if (ref $act->{$key}) {
190 1         3 $message .= "$key: $_$EOL" for @{ $act->{$key} };
  1         8  
191             } else {
192 13         35 $message .= "$key: $act->{$key}$EOL";
193             }
194             }
195              
196 7         10 $message .= $EOL; # Message ends with blank line
197              
198             # If debugging, print out the message before sending it
199 7 50       18 if ($self->{Debug_FH}) {
200 0         0 my $debug = $message;
201 0         0 $debug =~ s/\r//g;
202 0         0 $debug =~ s/^/>> /mg;
203 0         0 print { $self->{Debug_FH} } $debug;
  0         0  
204             }
205              
206             # Send the request to Asterisk
207 7 50       7 unless (print { $self->{socket} } $message) {
  7         42  
208 0         0 $self->{error} = "Writing to socket failed: $!";
209 0         0 return undef;
210             }
211              
212 7         156 $id;
213             } # end send_action
214             #---------------------------------------------------------------------
215              
216              
217             sub read_response {
218 9     9 1 11 my $self = shift;
219              
220             # Check that the connection is open
221 9         20 my $socket = $self->{socket};
222 9 50       38 unless ($socket) {
223             return {
224             Response => 'Error',
225 0         0 Message => $self->{error} = "Not connected to Asterisk!",
226             };
227             }
228              
229             # Read a response terminated by a blank line
230 9         29 local $/ = $EOL;
231 9         12 my $debug_fh = $self->{Debug_FH};
232 9         12 my ($line, %response);
233 9         15 undef $!;
234              
235 9         26 while ($line = <$socket>) {
236 60         274 chomp $line;
237 60 50       113 print $debug_fh "<< $line\n" if $debug_fh;
238              
239 60 100       137 return \%response unless length $line;
240              
241             # Remove the key from the "Key: Value" line
242             # If the line is not in that format, ignore it.
243 51 50       224 $line =~ s/^([^:]+): // or next;
244              
245 51 100       144 if (not exists $response{$1}) {
    100          
246             # First occurrence of this key, save as string
247 45         157 $response{$1} = $line;
248             } elsif (ref $response{$1}) {
249             # Third or more occurrence of this key, append to arrayref
250 2         3 push @{ $response{$1} }, $line;
  2         9  
251             } else {
252             # Second occurrence of this key, convert to arrayref
253 4         19 $response{$1} = [ $response{$1}, $line ];
254             }
255             } # end while reading from $socket
256              
257             # There was a communication failure; return an error.
258             return {
259             Response => 'Error',
260 0         0 Message => $self->{error} = "Reading from socket failed: $!",
261             };
262             } # end read_response
263              
264             #---------------------------------------------------------------------
265              
266              
267 7     7 1 28 sub error { shift->{error} }
268              
269             #=====================================================================
270             # Package Return Value:
271              
272             1;
273              
274             __END__