package Dancer::Plugin::RPC::XML;

use strict;
use warnings;

use Dancer ':syntax';
use Dancer::Exception ':all';
use Dancer::Plugin;
use RPC::XML;
use RPC::XML::ParserFactory;

our $VERSION = '0.06';

register 'xmlrpc' => \&xmlrpc;
register 'xmlrpc_fault' => \&xmlrpc_fault;

hook before => sub {
  if (request->is_post) {
    content_type('text/xml');
  }
};

sub xmlrpc {
  my ($pattern, @rest) = @_;
  
  my $code;
  for my $e (@rest) { 
    $code = $e if ref($e) eq 'CODE';
  }

  my $rpcxml_route = sub {  
    if ( not request->is_post ) {
      pass and return 0;
    }
  
    # disable layout
    my $layout = setting('layout');
    setting('layout' => undef);
  
    # parse the request body
    my $xml = request->body;
		
    return RPC::XML::response->new(
      RPC::XML::fault->new(-1,  "XML parse failure - empty"))->as_string if ( !$xml || $xml =~ /^\s?$/ );
	
    my $reqobj = RPC::XML::ParserFactory->new()->parse( $xml );
  
    if ( not ref $reqobj ) {
      return RPC::XML::response->new(
        RPC::XML::fault->new(-2,  "XML parse failure: $reqobj"))->as_string;
    }
  
    my @data = @{$reqobj->args};
    my $name = $reqobj->name;
  
    my @values = ();
    for my $v (@data) { push @values, $v->value; };
  
    # stuff data into params
    request->_set_route_params( { 'method' => $name, 'data' => \@values } );
  
    # call the code
    my $response = try {
      $code->();
    } catch {
      my $e = $_;
      setting('layout' => $layout);
      die $e;
    };

    # re-enable layout
    setting('layout' => $layout);

    # wrap the response in xml with RPC::XML
		if ( ref $response ne 'RPC::XML::response' ) {
    	return RPC::XML::response->new( $response )->as_string;
		}
		else {
		 	return $response->as_string;
		}
  };

  # rebuild the @rest array with the compiled route handler
  my @compiled_rest;
  for my $e (@rest) {
    if (ref($e) eq 'CODE') {
      push @compiled_rest, {}, $rpcxml_route;
    }
    else {
      push @compiled_rest, {}, $e;
    }
  }
 
  any ['post'] => $pattern, @compiled_rest;
	#any ['get', 'post'] => $pattern, @compiled_rest;
}

sub xmlrpc_fault {
  return RPC::XML::response->new(RPC::XML::fault->new( @_ ));
};

register_plugin;
1; # End of Dancer::Plugin::RPC::XML

=head1 NAME

Dancer::Plugin::RPC::XML - A plugin for Dancer to wrap XML-RPC calls

=head1 VERSION

Version 0.06

=head1 SYNOPSIS

Quick summary of what the module does.

  # in your app.pl
  use Dancer::Plugin::RPC::XML;

	xmlrpc '/foo/bar' => sub {
	  # methodname
	  my $method = params->{method};
    # listref of data
    my $data = params->{data};

    return xmlrpc_fault(100,"Undefined method") unless $method =~ /something_known/;

	  my $response;
 
    $response->{name} = "John Smith";

	  return $response;
  };
 
=head1 REGISTERED METHODS

=head2 xmlrpc
 
Route handler for xmlrpc routes. Unwraps requests and re-wraps responses in xml using
the RPC::XML module.

=head2 xmlrpc_fault( $faultCode, $faultString )

Returns xmlrpc fault xml

=head1 AUTHOR

Jesper Dalberg, C<< <jdalberg at gmail.com> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-dancer-plugin-rpc-xml at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Dancer-Plugin-RPC-XML>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Dancer::Plugin::RPC::XML

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dancer-Plugin-RPC-XML>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Dancer-Plugin-RPC-XML>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Dancer-Plugin-RPC-XML>

=item * Search CPAN

L<http://search.cpan.org/dist/Dancer-Plugin-RPC-XML/>

=back

=head1 ACKNOWLEDGEMENTS

=over

=item * Thanks to Randy J Ray (RJRAY) for the wonderful RPC::XML module
 
=item * Thanks to the Dancer project for creating an alternative to CGI!

=back

=head1 COPYRIGHT & LICENSE

Copyright 2012 Jesper Dalberg, all rights reserved.

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

=cut