File Coverage

blib/lib/Wily/Message.pm

Criterion	Covered	Total	%
statement	40	42	95.2
branch	7	12	58.3
condition			n/a
subroutine	11	12	91.6
pod	0	5	0.0
total	58	71	81.6

package Wily::Message;

use v5.8;
use strict;
use warnings;
use Carp;
use Encode qw/decode_utf8 encode_utf8/;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Wily::Message ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'constants' => [ qw(WEexec WEgoto WEdestroy WEreplace
	WEfencepost WRerror WMlist WRlist WMnew WRnew WMattach WRattach
	WMsetname WRsetname WMgetname WRgetname WMsettools WRsettools
	WMgettools WRgettools WMread WRread WMreplace WRreplace WMexec WRexec
	WMgoto WRgoto WMgetfeatures WRgetfeatures WMdetach WRdetach WMfencepost
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'constants'} } );

our $VERSION = '0.01';

use constant {
	# EVENTS (and event masks)
	WEexec => 1,
	WEgoto => 2,
	WEdestroy => 4,
	WEreplace => 8,

	WEfencepost =>9,

	# REQUESTS AND RESPONSES
	WRerror => 10,
	WMlist => 11,
	WRlist => 12,
	WMnew => 13,
	WRnew => 14,
	WMattach => 15,
	WRattach => 16,
	WMsetname => 17,
	WRsetname => 18,
	WMgetname => 19,
	WRgetname => 20,
	WMsettools => 21,
	WRsettools => 22,
	WMgettools => 23,
	WRgettools => 24,
	WMread => 25,
	WRread => 26,
	WMreplace => 27,
	WRreplace => 28,
	WMexec => 29,
	WRexec => 30,
	WMgoto => 31,
	WRgoto => 32,

	# Non-standard messages
	WMgetfeatures => 33,
	WRgetfeatures => 34,
	WMdetach => 35,
	WRdetach => 36,

	WMfencepost => 37,
};

our $COOKIE = 0xfeed;
our $HEADER_SIZE = 22;


sub new {
	my $package = shift;
	my ($type, $win, $p0, $p1, $flag, $s) = @_;
	for ($type, $win, $p0, $p1, $flag) {
		$_ = 0 unless defined;
	}
	$s = '' unless defined $s;

	my $self = {'type' => $type,
		'message_id' => 0,
		'window_id' => $win,
		'p0' => $p0,
		'p1' => $p1,
		'flag' => $flag,
		's' => $s
	};
	return bless $self, $package;
}

sub flatten {
	my $self = shift;
	return pack('nnNnnNNna'.(length($self->{s})+1), $COOKIE,
		$self->{type}, $self->size(), $self->{message_id},
		$self->{window_id}, $self->{p0}, $self->{p1},
		$self->{flag}, encode_utf8($self->{s}));
}

sub size {
	my $self = shift;
	return $HEADER_SIZE + 1 + length(encode_utf8($self->{s}));
}

sub from_string {
	my $self = shift;
	my $msg = shift;
	my $size = _message_length($msg);
	my $cookie;
	($cookie, $self->{type}, undef, $self->{message_id}, $self->{window_id},
	$self->{p0}, $self->{p1}, $self->{flag}, $self->{s}) =
		unpack('nnNnnNNna'.($size-1-$HEADER_SIZE), $msg);
	croak "Invalid Cookie" unless $cookie eq $COOKIE;
	$self->{s} = decode_utf8($self->{s});
	return $size
}


sub _message_length {
	my $buffer = shift;
	croak "Buffer shorter than header size" unless length($buffer) > $HEADER_SIZE;
	return unpack('N', substr($buffer, 4));
}

sub complete_message {
	my $buffer = shift;
	return length($buffer) > $HEADER_SIZE and
		length($buffer) >= _message_length($buffer);
}


1;
__END__