#!/usr/bin/perl

=head1 NAME

wl-scanner.pl - Generate Perl bindings for Wayland protocol

=head1 SYNOPSIS

B<wl-draw.pl>
[<wayland.xml>]

=head1 DESCRIPTION

This tool processes Wayland protocol specification and generates L<WL::Base>
subclasses with wrappers for requests, event processing and constants for enums.

=cut

use strict;
use warnings;

use XML::Smart;

# Information for type marshalling/unmarshalling:
# [ <routine returning pack string and code for fetching the value from
#   argument stack>, <routine returning pack string and code that obtains
#   the actual value given unpacked data on an argument stack >], ...
my %typemap = (
	int	=> [
		sub { 'l' => 'shift' },
		sub { 'l' => 'shift' }],
	uint	=> [
		sub { 'L' => 'shift' },
		sub { 'L' => 'shift' }],
	fixed	=> [
		sub { 'l' => '$self->nv2fixed ($_)' },
		sub { 'L' => '$self->fixed2nv (shift)' }],
	string	=> [
		sub { 'L/ax!4' => 'shift."\x00"' },
		sub { 'L/ax!4' => '[shift =~ /(.*)./]->[0]' }],
	object	=> [
		sub { 'L' => 'shift->{id}' },
		sub { 'L' => 'new WL::'.(shift->{interface} || 'Base').' ($self->{conn}, shift)' },
	],
	new_id	=> [
		sub { my $interface = shift->{interface}; $interface
			? ('L' => '($retval = new WL::'.$interface.' ($self->{conn}))->{id}')
			: ('L/ax!4 L L' => '$_[0]."\x00", delete $_[1], ($retval = ("WL::".shift)->new ($self->{conn}))->{id}') },
		sub { 'L' => 'new WL::'.shift->{interface}.' ($self->{conn})' }],
	array	=> [
		sub { 'L/ax!4' => 'shift' },
		sub { 'L/ax!4' => 'shift' }],
	fd	=> [
		sub { '' => '($file = shift, ())' },
		sub { '' => 'shift' }]
);

sub process_request
{
	my $request = shift;

	print "sub $request->{name}\n";
	print "{\n";
	print "\tmy \$self = shift;\n";
	print "\tmy \$file;\n";
	print "\tmy \$retval;\n";
	print "\n";

	my @pack;
	my @map;
	foreach my $arg ($request->{arg}('@')) {
		my ($pack, $map) = $typemap{$arg->{type}}[0]->($arg);
		push @pack, $pack if $pack;
		push @map, $map;
	}
	my $pack = join ' ', @pack;
	my $map = join ",\n\t\t", @map;

	printf "\t\$self->call (REQUEST_%s, pack ('%s',\n\t\t%s), \$file);\n",
		uc ($request->{name}), $pack, $map;
	print "\n";

	print "\treturn \$retval;\n";
	print "}\n";
	print "\n";
}

sub process_event
{
	my $event = shift;

	my @pack;
	my @map;
	foreach my $arg ($event->{arg}('@')) {
		my ($pack, $map) = $typemap{$arg->{type}}[1]->($arg);
		push @pack, $pack if $pack;
		push @map, $map;
	}
	my $pack = join ' ', @pack;
	my $map = join ",\n\t\t\t", @map;

	print "\t\t\@_ = unpack ('$pack', shift);\n" if $pack;
	print "\t\treturn \$self->$event->{name} ($map);\n";
}

sub process_enum
{
	my $enum = shift;

	foreach my $entry ($enum->{entry}('@')) {
		printf "use constant %s => %s;\n",
			uc ($enum->{name}.'_'.$entry->{name}),
			$entry->{value};
	}
}

sub process_interface
{
	my $interface = shift;
	my $opcode;

	printf "package WL::$interface->{name};\n";
	print "\n";
	print "our \@ISA = qw/WL::Base/;\n";
	print "our \$VERSION = $interface->{version};\n";
	print "our \$INTERFACE = '$interface->{name}';\n";
	print "\n";

	my @requests = $interface->{request}('@');
	if (@requests) {
		$opcode = 0;
		print "# Requests\n";
		foreach my $request (@requests) {
			printf "use constant REQUEST_%s => %d;\n",
				uc ($request->{name}), $opcode++;
		}
		print "\n";
		foreach my $request (@requests) {
			process_request ($request);
		}
	}

	my @events = $interface->{event}('@');
	if (@events) {
		$opcode = 0;
		print "# Events\n";
		foreach my $event (@events) {
			printf "use constant EVENT_%s => %d;\n",
				uc ($event->{name}), $opcode++;
		}

		print "\n";
		print "sub callback\n";
		print "{\n";
		print "\tmy \$self = shift;\n";
		print "\tmy \$opcode = shift;\n";
		print "\n";

		print "\t";
		foreach my $event (@events) {
			printf "if (\$opcode == EVENT_%s) {\n", uc ($event->{name});
			process_event ($event);
			print "\t} els";
		}
		print "e {\n";
		print "\t\tdie 'Bad opcode';\n";
		print "\t}\n";

		print "}\n";
		print "\n";
	}

	my @enums = $interface->{enum}('@');
	if (@enums) {
		print "# Enums\n";
		foreach my $enum (@enums) {
			process_enum ($enum);
		}
		print "\n";
	}
}

sub process_protocol
{
	my $protocol = shift;

	print "package WL;\n";
	print "\n";
	print "our \$VERSION = 0.90;\n";
	print "\n";

	foreach my $interface ($protocol->{interface}('@')) {
		process_interface ($interface);
	}
}

my $source = shift @ARGV || 'wayland.xml';
print "# DO NOT EDIT, PRETTY PLEASE!\n";
print "# This file is automatically generated by wl-scanner.pl\n";
print "#\n";
print "\n";
print "use strict;\n";
print "use warnings;\n";
print "use utf8;\n";
print "\n";
print "=encoding utf8\n";
print "=cut\n";
print "\n";

# Trick POD parser so that it does not consider this to be a documentation for
# the tool itself.
my $P = '=';

print <<POD;

${P}head1 NAME

WL - Perl Wayland protocol binding

${P}head1 SYNOPSIS

  use WL;

${P}head1 DESCRIPTION

B<WL> is a package generated from Wayland protocol definition using
L<wl-scanner.pl>. It implements L<WL::Base> subclasses with wrappers for
requests, event processing and constants for enums.

It is not indended to be used directly. Instead, see L<WL::Connection> to see
how to obtain the object instances.

To see how to attach event callbacks and issue requests, please refer to
L<WL::Base> base class.

Until proper documentation is finished, please refer to documentation of C
bindings of the generated code (it is intended to be readable) to see what
arguments to give to requests and expect from events.

Please consider this an alpha quality code, whose API can change at any time,
until we reach version 1.0.

${P}cut

POD

my $spec = new XML::Smart ($source);
process_protocol ($spec->{protocol});

print <<POD;

${P}head1 BUGS

The interface documentation for the bindings is lacking.

Only client part implemented, not server.

${P}head1 SEE ALSO

${P}over

${P}item *

L<http://wayland.freedesktop.org/> -- Wayland project web site

${P}item *

L<wl-demo.pl> -- Example Wayland client

${P}item *

L<wl-scanner.pl> -- Tool that generated this module

${P}item *

L<WL::Base> -- Base class for Wayland objects

${P}item *

L<WL::Connection> -- Estabilish a Wayland connection

${P}back

${P}head1 COPYRIGHT

Copyright 2013 Lubomir Rintel

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

POD

print "Copyright notice from the protocol definition file:\n\n";
# XML::Smart recodes this to ISO-8859 for some weird reason,
# therefore we won't use $spec->{protocol}{copyright} here.
open (my $file, '<', $source);
my @copyright = map { /<copyright>/ .. /<\/copyright>/ ? $_ : () } <$file>;
shift @copyright;
pop @copyright;
map { s/\s*(.*\S?)\s*/$1\n/ } @copyright;
print @copyright;

print <<POD;

${P}head1 AUTHORS

Lubomir Rintel C<lkundrak\@v3.sk>

${P}cut

POD

=head1 SEE ALSO

=over

=item *

L<http://wayland.freedesktop.org/> -- Wayland project web site

=item *

L<WL> -- Perl Wayland protocol binding

=back

=head1 COPYRIGHT

Copyright 2013 Lubomir Rintel

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 AUTHORS

Lubomir Rintel C<lkundrak@v3.sk>

=cut
