File Coverage

blib/lib/Net/Snarl.pm

Criterion	Covered	Total	%
statement	15	55	27.2
branch	0	28	0.0
condition	0	12	0.0
subroutine	5	11	45.4
pod	3	3	100.0
total	23	109	21.1

## no critic
package Net::Snarl;
{
  $Net::Snarl::VERSION = '1.09'; # TRIAL
}
## use critic

use strict;
use warnings;

use IO::Socket;
use Carp;

=head1 NAME

Net::Snarl - Snarl network protocol

=head1 VERSION

version 1.09

=cut

use Readonly;
Readonly my $SNARL_PORT           => 9887;
Readonly my $SNARL_PROTO_VERSION  => '1.1';

=head1 SYNOPSIS

  use Net::Snarl;

  # connect to localhost and register Net::Snarl application
  my $snarl = Net::Snarl->register('Net::Snarl');
  $snarl->add_class('Test'); # add Test notification class
  $snarl->notify('Test', 'Hello', 'World', 5); # show hello world for 5 seconds

=head1 DESCRIPTION

A simple interface to send Snarl notifications across the network.  Snarl must
be running on the target machine.

=cut

sub _send {
  my ($self, %param) = @_;

  my $data = 'type=SNP#?version=' . $SNARL_PROTO_VERSION . '#?' .
    join('#?', map { "$_=$param{$_}" } keys %param);

  $self->{socket}->print("$data\x0d\x0a");
  return $self->_recv;
}

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

  my $data = $self->{socket}->getline();
  chomp $data;

  my ($header, $version, $code, $desc, @rest) = split '/', $data;

  die "Unexpected response: $data" unless $header eq 'SNP';

  # hackishly disregard responses above 300
  if ($code >= 300) {
    push @{$self->{queue}}, [$code, $desc, @rest];
    return $self->_recv;
  }

  return $code, $desc, @rest;
}

=head1 INTERFACE

=head2 register($application, $host, $port)

Connects to Snarl and register an application.  Host defaults to localhost and
port defaults to C<$Net::Snarl::SNARL_PORT>.

=cut

sub register {
  my ($class, $application, $host, $port) = @_;

  croak 'Cannot call register as an instance method' if ref $class;
  croak 'Application name required' unless $application;

  my $socket = IO::Socket::INET->new(
    PeerAddr  => $host || 'localhost',
    PeerPort  => $port || $SNARL_PORT,
    Proto     => 'tcp',
  ) or die "Unable to create socket: $!";

  my $self = bless { socket => $socket, application => $application }, $class;

  my ($result, $text) = $self->_send(
    action => 'register',
    app => $application,
  );

  die "Unable to register: $text" if $result;

  return $self;
}

=head2 add_class($class, $title)

Registers a notification class with your application.  Title is the optional
friendly name for the class.

=cut

sub add_class {
  my ($self, $class, $title) = @_;

  croak 'Cannot call add_class as a class method' unless ref $self;
  croak 'Class name required' unless $class;

  my ($result, $text) = $self->_send(
    action  => 'add_class',
    app     => $self->{application},
    class   => $class,
    title   => $title || $class,
  );

  die "Unable to add class: $text" if $result;

  return 1;
}

=head2 notify($class, $title, $text, $timeout, $icon)

Displays a notification of the specified class.  Timeout defaults to 0 (sticky)
and icon defaults to nothing.

=cut

sub notify {
  my ($self, $class, $title, $text, $timeout, $icon) = @_;

  croak 'Cannot call notify as a class method' unless ref $self;
  croak 'Class name required' unless $class;
  croak 'Title required' unless $title;
  croak 'Text required' unless $text;

  my ($result, $rtext) = $self->_send(
    action  => 'notification',
    app     => $self->{application},
    class   => $class,
    title   => $title,
    text    => $text,
    timeout => $timeout || 0,
    icon    => $icon || '',
  );

  die "Unable to send notification: $rtext" if $result;

  return 1;
}

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

  $self->_send(
    action  => 'unregister',
    app     => $self->{application},
  );

  return;
}

=head1 BUGS

Please report and bugs or feature requests on GitHub
L

=head1 TODO

Later versions of Snarl report interactions with the notifications back to the
socket.  Currently these are stored in a private queue.  Eventually, I will
expose an interface for triggering callbacks on these events but that will most
likely require threading so I'm a little reluctant to implement it.

=head1 AUTHOR

Alan Berndt, C<<  >>

=head1 LICENSE AND COPYRIGHT

Copyright 2013 Alan Berndt.

This program is free software; you can redistribute it and/or modify it under
the terms of either: the GNU General Public License as published by the Free
Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Net::Snarl