File Coverage

blib/lib/AnyEvent/Net/MPD.pm

Criterion	Covered	Total	%
statement	33	126	26.1
branch	1	38	2.6
condition	0	15	0.0
subroutine	11	25	44.0
pod	5	7	71.4
total	50	211	23.7

package AnyEvent::Net::MPD;

use strict;
use warnings;

our $VERSION = '0.002';

use Moo;
use MooX::HandlesVia;
extends 'AnyEvent::Emitter';

use AnyEvent;
use AnyEvent::Socket;
use AnyEvent::Handle;

use Types::Standard qw(
  InstanceOf Int ArrayRef HashRef Str Maybe Bool CodeRef
);

use Log::Any;
my $log = Log::Any->get_logger( category => __PACKAGE__ );

has version => (
  is => 'ro',
  isa => Str,
  lazy => 1,
  init_arg => undef,
);

has auto_connect => (
  is => 'ro',
  isa => Bool,
  default => 0,
);

has state => (
  is => 'rw',
  isa => Str,
  init_arg => undef,
  default => 'created',
  trigger => sub {
    $_[0]->emit( state => $_[0]->{state} );
  },
);

has read_queue => (
  is => 'ro',
  isa => ArrayRef [CodeRef],
  lazy => 1,
  init_arg => undef,
  default => sub { [] },
  handles_via => 'Array',
  handles => {
    push_read    => 'push',
    pop_read     => 'pop',
    shift_read   => 'shift',
    unshift_read => 'unshift',
  },
);

has password => (
  is => 'ro',
  isa => Maybe[Str],
  lazy => 1,
);

has port => (
  is => 'ro',
  isa => Int,
  lazy => 1,
  default => sub { $ENV{MPD_PORT} // 6600 },
);

has host => (
  is => 'ro',
  isa => Str,
  lazy => 1,
  default => sub { $ENV{MPD_HOST} // 'localhost' },
);

has _uri => (
  is => 'ro',
  init_arg => undef,
  lazy => 1,
  default => sub {
    my $self = shift;
      ( $self->password ? $self->password . '@' : q{} )
    . $self->host
    . ( $self->port     ? ':' . $self->port     : q{} )
  },
);

has [qw( handle socket )] => ( is => 'rw', init_arg => undef, );

{
  my @buffer;
  sub _parse_block {
    my $self = shift;
    return sub {
      my ($handle, $line) = @_;

      if ($line =~ /\w/) {
        $log->tracef('< %s', $line);
        if ($line =~ /^OK/) {
          if ($line =~ /OK MPD (.*)/) {
            $log->trace('Connection established');
            $self->{version} = $1;

            $self->send( password => $self->password )
              if $self->password and $self->state ne 'ready';

            $self->state( 'ready' );
          }
          else {
            $self->shift_read->( \@buffer );
            @buffer = ();
          }
        }
        elsif ($line =~ /^ACK/) {
          return $self->emit(error => $line );
          @buffer = ();
        }
        else {
          push @buffer, $line;
        }
      }

      $handle->push_read( line => $self->_parse_block );
    };
  }
}

# Set up response parsers for each command
my $parsers = { none => sub { @_ } };
{
  my $item = sub {
    return { map {
      my ($key, $value) = split /: /, $_, 2;
      $key => $value;
    } @{$_[0]} };
  };

  my $flat_list = sub { [ map { (split /: /, $_, 2)[1] } @{$_[0]} ] };

  my $base_list = sub {
    my @main_keys = @{shift()};
    my @list_keys = @{shift()};
    my @lines     = @{shift()};

    my @return;
    my $item = {};

    foreach my $line (@lines) {
      my ($key, $value) = split /: /, $line, 2;

      if ( grep { /$key/ } @main_keys ) {
        push @return, $item if defined $item->{$key};
        $item = { $key => $value };
      }
      elsif ( grep { /$key/ } @list_keys ) {
        unless (defined $item->{$key}) {
          $item->{$key} = []
        }
        push @{$item->{$key}}, $value;
      }
      else {
        $item->{$key} = $value;
      }
    }
    push @return, $item if keys %{$item};

    return \@return;
  };

  my $grouped_list = sub {
    my @lines = @{shift()};

    # What we are grouping
    my ($main) = split /:\s+/, $lines[0], 2;

    # How we are grouping, from top to bottom
    my (@categories, %categories);
    foreach (@lines) {
      my ($key) = split /:\s+/, $_, 2;

      if ($key ne $main) {
        push @categories, $key unless defined $categories{$key};
        $categories{$key} = 1;
      }
    }

    my $return = {};
    my $item;
    foreach my $line (@lines) {
      my ($key, $value) = split /:\s+/, $line, 2;

      if (defined $item->{$key}) {
        # Find the appropriate list of items or create a new one
        # and populate it
        my $pointer = $return;
        foreach my $key (@categories) {
          my $val = $item->{$key} // q{};
          $pointer->{$key}{$val} = {} unless defined $pointer->{$key}{$val};
          $pointer = $pointer->{$key}{$val};
        }
        $pointer->{$main} = [] unless defined $pointer->{$main};
        my $list = $pointer->{$main};

        push @{$list}, delete $item->{$main};

        # Start a new item
        $item = { $key => $value };
        next;
      }

      $item->{$key} = $value;
    }
    return $return;
  };

  # Untested commands: what do they return?
  # consume
  # crossfade

  my $file_list = sub { $base_list->( [qw( directory file )], [], @_ ) };

  $parsers->{$_} = $flat_list foreach qw(
    commands notcommands channels tagtypes urlhandlers listplaylist
  );

  $parsers->{$_} = $item foreach qw(
    currentsong stats idle status addid update
    readcomments replay_gain_status rescan
  );

  $parsers->{$_} = $file_list foreach qw(
    find playlistinfo listallinfo search find playlistid playlistfind
    listfiles plchanges listplaylistinfo playlistsearch listfind
  );

  $parsers->{list} = $grouped_list;

  foreach (
      [ outputs        => [qw( outputid )],  [] ],
      [ plchangesposid => [qw( cpos )],      [] ],
      [ listplaylists  => [qw( playlist )],  [] ],
      [ listmounts     => [qw( mount )],     [] ],
      [ listneighbors  => [qw( neighbor )],  [] ],
      [ listall        => [qw( directory )], [qw( file )] ],
      [ readmessages   => [qw( channel )],   [qw( message )] ],
      [ lsinfo         => [qw( directory file playlist )], [] ],
      [ decoders       => [qw( plugin )], [qw( suffix mime_type )] ],
    ) {

    my ($cmd, $header, $list) = @{$_};
    $parsers->{$cmd} = sub { $base_list->( $header, $list, @_ ) };
  }

  $parsers->{playlist} = sub {
    my $lines = [ map { s/^\w*?://; $_ } @{shift()} ];
    $flat_list->( $lines, @_ )
  };

  $parsers->{count} = sub {
    my $lines = shift;
    my ($main) = split /:\s+/, $lines->[0], 2;
    $base_list->( [ $main ], [qw( )], $lines, @_ )
  };

  $parsers->{sticker} = sub {
    my $lines = shift;
    return {} unless scalar @{$lines};

    my $single = ($lines->[0] !~ /^file/);

    my $base = $base_list->( [qw( file )], [qw( sticker )], $lines, @_ );
    my $return = [ map {
      $_->{sticker} = { map { split(/=/, $_, 2) } @{$_->{sticker}} }; $_;
    } @{$base} ];

    return $single ? $return->[0] : $return;
  };
}

{
  my $cv;

  sub idle {
    my ($self, @subsystems) = @_;

    $cv = AnyEvent->condvar;

    my $idle;
    $idle = sub {
      my $o = shift->recv;
      $self->emit( $o->{changed} );
      $self->send( idle => @subsystems, $idle ) unless $cv->ready;
    };
    $self->send( idle => @subsystems, $idle );

    return $cv;
  }

  sub noidle {
    my ($self) = @_;
    $cv->send if $cv;
    $self->send( 'noidle' );
    return $self;
  }
}

sub send {
  my $self = shift;
  my $opt  = ( ref $_[0] eq 'HASH' ) ? shift : {};
  my $cb = pop if ref $_[-1] eq 'CODE';
  my (@commands) = @_;

  # Normalise input
  if (ref $commands[0] eq 'ARRAY') {
    @commands = map {
      ( ref $_ eq 'ARRAY' ) ? join( q{ }, @{$_} ) : $_;
    } @{$commands[0]};
  }
  else {
    @commands = join q{ }, @commands;
  }

  my $command = '';
  # Remove underscores from command names
  @commands = map {
    my $args;
    ($command, $args) = split /\s/, $_, 2;
    $command =~ s/_//g unless $command =~ /^replay_gain_/;
    $args //= q{};
    "$command $args";
  } @commands;

  # Create block if command list
  if (scalar @commands > 1) {
    unshift @commands, "command_list_begin";
    push    @commands, "command_list_end";
  }

  my $parser = $opt->{parser} // $command;
  $parser = $parsers->{$parser} // $parsers->{none}
    unless ref $parser eq 'CODE';

  my $cv = AnyEvent->condvar( $cb ? ( cb => $cb ) : () );

  $self->push_read( sub {
    my $response = shift;
    $cv->send( $parser->( $response ) );
  });

  $log->tracef( '> %s', $_ ) foreach @commands;
  $self->handle->push_write( join("\n", @commands) . "\n" );

  return $cv;
}

sub get { shift->send( @_ )->recv }

sub until {
  my ($self, $name, $check, $cb) = @_;

  weaken $self;
  my $wrapper;
  $wrapper = sub {
    if ($check->(@_)) {
      $self->unsubscribe($name => $wrapper);
      $cb->(@_);
    }
  };
  $self->on($name => $wrapper);

  return $wrapper;
}

sub BUILD {
  my ($self, $args) = @_;

  $self->socket( $self->_build_socket );

  $self->connect if $self->auto_connect;
}

sub _build_socket {
  my $self = shift;

  my $socket = tcp_connect $self->host, $self->port, sub {
    my ($fh) = @_
      or die "MPD connect failed: $!";

    $log->debugf('Connecting to %s:%s', $self->host, $self->port);
    $self->handle(
      AnyEvent::Handle->new(
        fh => $fh,
        on_error => sub {
          my ($hdl, $fatal, $msg) = @_;
          $self->emit( error => $msg );
          $hdl->destroy;
        },
      )
    );

    $self->handle->on_read(sub {
      $self->handle->push_read( line => $self->_parse_block )
    });

    $self->handle->on_error(sub {
      my ($h, $fatal, $message) = @_;
      $self->emit( error => $message // 'Error' );
      $self->handle(undef);
    });

    $self->handle->on_eof(sub {
      my ($h, $fatal, $message) = @_;
      $self->emit( eof => $message // 'EOF' );
      $self->handle(undef);
    });
  };

  return $socket;
}

sub connect {
  my ($self) = @_;

  return $self if $self->state eq 'ready';

  my $cv = AnyEvent->condvar;
  $self->until( state => sub { $_[1] eq 'ready' }, sub {
    $cv->send;
  });
  $cv->recv;

  return $self;
}

1;

__END__