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

#---------------------------------------------------------------------
package Telephony::Asterisk::AMI;
#
# Copyright 2015 Christopher J. Madsen
#
# Author: Christopher J. Madsen
# Created: 31 Oct 2015
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: Simple Asterisk Manager Interface client
#---------------------------------------------------------------------

use 5.008;
use strict;
use warnings;


use Carp ();
use IO::Socket::IP ();

our $VERSION = '0.005';
# This file is part of Telephony-Asterisk-AMI 0.005 (December 19, 2015)

my $EOL = "\r\n";

#=====================================================================


sub new {
  my $class = shift;
  my $args = (@_ == 1) ? shift : { @_ };

  my $self = bless {
    Debug_FH => ($args->{Debug_FH} || ($args->{Debug} ? *STDERR : undef)),
    Event_Callback => $args->{Event_Callback},
    Host => $args->{Host} || 'localhost',
    Port => $args->{Port} || 5038,
    ActionID => $args->{ActionID} || 1,
  }, $class;

  for my $key (qw(Username Secret)) {
    defined( $self->{$key} = $args->{$key} )
        or Carp::croak("Required parameter '$key' not defined");
  }

  $self;
} # end new
#---------------------------------------------------------------------


sub connect {
  my $self = shift;

  # Open a socket to Asterisk.
  #   IO::Socket::IP->new reports error in $@
  local $@;

  $self->{socket} = IO::Socket::IP->new(
    Type => IO::Socket::IP::SOCK_STREAM(),
    PeerHost => $self->{Host},
    PeerService => $self->{Port},
  );

  unless ($self->{socket}) {
    $self->{error} = "Connection failed: $@";
    return undef;
  }

  # Verify that we've connected to Asterisk Call Manager
  my $id = readline($self->{socket});

  unless (defined $id) {
    $self->{error} = "Connection closed without input: $!";
    undef $self->{socket};
    return undef;
  }

  chomp $id;
  print { $self->{Debug_FH} } "<< $id\n" if $self->{Debug_FH};

  if ($id =~ m!^Asterisk Call Manager/(.+)!) {
    $self->{protocol} = $1;
  } else {
    $self->{error} = "Unknown Protocol";
    undef $self->{socket};
    return undef;
  }

  # Automatically log in using Username/Secret
  my $response = $self->action({
    Action => 'Login',
    Username => $self->{Username},
    Secret => $self->{Secret},
  });

  # If login failed, set error
  unless ($response->{Response} eq 'Success') {
    $self->{error} = "Login failed: $response->{Message}";
    undef $self->{socket};
    return undef;
  }

  # Login successful
  1;
} # end connect
#---------------------------------------------------------------------


sub disconnect {
  my $self = shift;

  my $response = $self->action({Action => 'Logoff'});

  # If logoff failed, set error
  unless ($response->{Response} eq 'Goodbye') {
    $self->{error} = "Logoff failed: $response->{Message}";
    undef $self->{socket};
    return undef;
  }

  unless ($self->{socket}->close) {
    $self->{error} = "Closing socket failed: $!";
    undef $self->{socket};
    return undef;
  }

  undef $self->{socket};

  # Logoff successful
  1;
} # end disconnect
#---------------------------------------------------------------------


sub action {
  my $self = shift;

  # Send the request to Asterisk
  my $id = $self->send_action(@_) or return {
    Response => 'Error',
    Message => $self->{error},
  };

  # Read responses until we get the response to this action
  while (1) {
    my $response = $self->read_response;

    # If this is the response to the action we just sent,
    # or there was an error, return it.
    no warnings 'uninitialized';
    if (($response->{ActionID} eq $id) ||
        ($response->{Response} eq 'Error')) {
      return $response;
    }

    # If there is an event callback, send it this event
    if ($self->{Event_Callback}) {
      $self->{Event_Callback}->($response);
    }
  } # end infinite loop waiting for response
} # end action
#---------------------------------------------------------------------


sub send_action {
  my $self = shift;
  my $act = (@_ == 1) ? shift : { @_ };

  Carp::croak("Required parameter 'Action' not defined") unless $act->{Action};

  # Check that the connection is open
  unless ($self->{socket}) {
    $self->{error} = "Not connected to Asterisk!";
    return undef;
  }

  # Assemble the message to send to Asterisk
  my $id = $self->{ActionID}++;
  my $message = "ActionID: $id$EOL";

  for my $key (sort keys %$act) {
    if (ref $act->{$key}) {
      $message .= "$key: $_$EOL" for @{ $act->{$key} };
    } else {
      $message .= "$key: $act->{$key}$EOL";
    }
  }

  $message .= $EOL;             # Message ends with blank line

  # If debugging, print out the message before sending it
  if ($self->{Debug_FH}) {
    my $debug = $message;
    $debug =~ s/\r//g;
    $debug =~ s/^/>> /mg;
    print { $self->{Debug_FH} } $debug;
  }

  # Send the request to Asterisk
  unless (print { $self->{socket} } $message) {
    $self->{error} = "Writing to socket failed: $!";
    return undef;
  }

  $id;
} # end send_action
#---------------------------------------------------------------------


sub read_response {
  my $self = shift;

  # Check that the connection is open
  my $socket = $self->{socket};
  unless ($socket) {
    return {
      Response => 'Error',
      Message => $self->{error} = "Not connected to Asterisk!",
    };
  }

  # Read a response terminated by a blank line
  local $/ = $EOL;
  my $debug_fh = $self->{Debug_FH};
  my ($line, %response);
  undef $!;

  while ($line = <$socket>) {
    chomp $line;
    print $debug_fh "<< $line\n" if $debug_fh;

    return \%response unless length $line;

    # Remove the key from the "Key: Value" line
    # If the line is not in that format, ignore it.
    $line =~ s/^([^:]+): // or next;

    if (not exists $response{$1}) {
      # First occurrence of this key, save as string
      $response{$1} = $line;
    } elsif (ref $response{$1}) {
      # Third or more occurrence of this key, append to arrayref
      push @{ $response{$1} }, $line;
    } else {
      # Second occurrence of this key, convert to arrayref
      $response{$1} = [ $response{$1}, $line ];
    }
  } # end while reading from $socket

  # There was a communication failure; return an error.
  return {
    Response => 'Error',
    Message => $self->{error} = "Reading from socket failed: $!",
  };
} # end read_response

#---------------------------------------------------------------------


sub error { shift->{error} }

#=====================================================================
# Package Return Value:

1;

__END__