#!/usr/bin/perl
use strict;
BEGIN {
  `mkdir /tmp/_Inline` if ! -d '/tmp/_Inline';
};

use constant INTERVAL => 30;

my $url = 'http://inline.perl.org';


use Inline CPP => Config => 'AUTO_INCLUDE' => [ undef,
			    '#include <iostream>',
			    '#include <string>',
			    '#include <unistd.h>',
			    ' extern "C" {','#include "EXTERN.h"',
			    '#include "perl.h"',
			    '#include "XSUB.h"',
			    '#include "INLINE.h"',
			    ' }'],
                            DIRECTORY => '/tmp/_Inline',
			    LIBS => '-lghttp',
#                            FORCE_BUILD => 1,
                            CLEAN_AFTER_BUILD => 0,
			    ;

use Inline 'CPP';

my $h = new GHTTPUpdate( "http://inline.perl.org", INTERVAL );

$h->startTimer($h,
	       sub {
	              my $g = shift;
		      my $req = shift;
		      my $c = 0;
	              print STDERR "In the callback sub - The request was: ".
		                length($req)." Bytes\n";
		      #  parse content for links and then call for these 
		      my ( $part ) = $req =~ m/<P>Brian Ingerson(.*?)<P>/is;
		      $c++ while( $part =~ m/(<LI>)/igs );
		      print "Ingy is currently giving: ".$c." Talks \n";
		      my ( $url ) = $req =~ 
		             m/<A HREF=.(http\:\/\/search\.cpan\.org\/doc\/INGY\/Inline\-\d+\.\d+\/C\/C\-Cookbook\.pod).>/is;
		      if ( $url ){
		        print "The Cookbook URL is: ".$url."\n";
                        $g->setRequest($url);
                        print "The Inline Cookbook is currently: ".length($g->getRequest())."\n";
		      }
		   }
		 );


sub myfancycallback{

  #  Do some maniputation of values etc. before handing over
  #  To user defined anonymous subroutine
  my ( $callback, $ghttp, $request ) = @_;
  my @result = &{$callback}( $ghttp, $request );
  return @result;

}


=head1 NAME PERL2C++2PERL2C++

 A discussion of calling back and forth between perl and C++.
 One way of embedding C++ in perl and embedding perl in C++.

=head1 SYNOPSIS

 ./perl2c2perl2c
 This demo program was written on Linux RedHat 7.1 -
 it may need to be altered for other platforms.
 To run this file you will need:
  - the latest version ( 1.0.0 ) of libghttp from http://www.gnome.org 
   ( ftp://ftp.gnome.org/pub/GNOME/stable/latest/sources/libghttp-1.0.9.tar.gz ).
   unfortunately many of the versions that people seem to have out ther do not 
   support the retrieval of http headers that I use in this program -
   install this into the default path eg: /usr or /usr/local ( don't
   forget to run ldconfig ) - or modify the Inline directives to point 
   to the appropriate path.
  - Inline/Inline::CPP ofcourse :-) - http://inline.perl.org
  - and this script - http://www.ompa.net/download/perl2c2perl2c.pl



=head1 DESCRIPTION

This is a discussion into calling back and forth between perl and C++ - how to go about utilising the power of both these languages in the same application.  This orriginally started out when I wanted to try and write mod_perl for Jabber ( see http://www.jabber.org )  - an XML based messaging platform.  I wanted to beable to write high performance plugins to the Jabber server in Perl.
After a digging arround for a while I came across some new C++ based component libraries called JECL ( see http://jabber.tigris.org ).  These seemed like a better solution as they did not need to be built directly in to the jabber server ( like JSM modules ) - instead they plug in via a socket connection.
Additionally, I had recently been an avid user of Inline ( http://inline.perl.org ), a really exciting perl module by Brian Ingerson for using other programming languages in perl - Inline takes all the heart ache/back break out of embedding C/C++/JAva/Python/ASM ( but to name a few ), in perl code - making building and running hybrid applications seamless.
Neil Watkiss wrote Inline::CPP ( and many others ), and seemed like the natural starting point for incorporating the JECL libraries.

From this was born Jabber::JAX::Component - for building JAbber components in perl - http://www.pipetree.com/jabber/ .

=head1 The Problem

There are two main complications to the problem I faced:

=item B<Threading>

In order to make the JECL libraries high performant, a threading model was used.  This can cause havoc with the perl interpreter.  The answer to this was relatively simple.  When embedding perl in a threaded environment you currently cannot use a threaded perl ie.  do not build perl with -Dusethreads or -Duseithreads or -D5005threads.  Instead use -Dusemultiplicity.  This ensures that the perl interpreter does additional work in cleaning down after each call.  Currently ( at the time of writing ) RedHat 7.1 standard perl build works.

=item B<The Callback>

The second problems was the architecture of the JECL libraries.  Basically - like Apache and mod_perl, the JECL component libraries are in control of when user space code is called in perl.  This is a callback model.

=over 2

B<Perl Script runs>
  User defines parameters for the instanatiation of a Jabber component including connection parameters and the Anonymous subroutine for callback Then the JECL router ( the Jabber component connector ) is started.

B<Into the land of C++>
  At this point the user ( perl programmer ) nolonger has any control.

B<Some time later ...>
  An XML packet is received by the router, and the user callback is routine is called.

B<Jump to Perl space>
  The user callback is an anonymous subroutine.  It needs to be passed a reference to the incoming packet, and a reference to the router object.  The router object is necessary because it contains C++ functions that are necessary for manipulating the XML packets.

B<An XML Packet is Created>
  The User constructs and XML packet and then calls the router object deliver function, passing the packet as an argument.

B<Back to C++ again>
  The deliver routine is a native function of the JECL C++ libraries - it takes an XML Packet and queues it up for delivery with one of the available threads.

=back


=head1 Distilling the problem and Creating a Solution

Putting together an example that could be fitted into one file proved to be a bit of a challenge :-), but hopefully, here we have it.
Inorder to demonstrate the solution - I have chosen to create a simpler application from scratch.  This application hopefully has all the key characteristics of the Jabber Component libraries:
  - Creates a "server"/"router" object, passes in details about the perl based callback.
  - kicks off the server object.  At that point in time the parent perl program passes control into the C++ object that has been called, and only has furhter influence by virtue of the callbakc subroutine supplied.
  - The server object periodically invokes the perl callback routine.
  - The perl callback routine uses an encapsulated method of the C++ server object.

The scenario is a C++ class that encapsulates the Gnome ( http://www.gnome.org ) http library (ftp://ftp.gnome.org/pub/GNOME/stable/latest/sources/libghttp-1.0.9.tar.gz).  The GHTTPUpdate class allows the user to create an http object that has a timer ( it will repeat a basic http call at a given interval ), and then performs the users callback routine everytime a URL is retrieved, passing in the http object, and the base request content.

I have stripped out the inline stuff to try and make the documentation smaller - when you wnat to view this then look at the raw file ( instead of the pod documentation ).
We end up wit something like this:


=item B<Perl Script>

#Create an intsance of the http timer object 
# go to inline.perl.org every 300 seconds
my $h = new GHTTPUpdate( "http://inline.perl.org", 300 );

 # Start the timer passing a reference to itself and the 
 #   callback subroutine
 $h->startTimer($h,
                sub {
                      my $http = shift;
                      my $req = shift;
                      print "inside the callback ....\n";
		      $http->setRequest("http://localhost");
		      print $http->getRequest();
                    }
    );

 # This is the base subroutine that is called before the 
 #  users anonymous subroutine is called 
 #  This is not necessary but can be used to provide an
 # opportunity to manipulate values before passing on to the
 # user defined anonymous subroutine

 sub myfancycallback{
  #  Do some maniputation of values etc. before handing over
  #  To user defined anonymous subroutine
     my ( $callback, $ghttp, $request ) = @_;
     my @result = &{$callback}( $ghttp, $request );
     return @result;
 }

=item B<C++ Class>

 class GHTTPUpdate
 {
   //  Create an ghttp request object and store away the 
   // base url and timer interval values in the constructor
   public:
      GHTTPUpdate(SV* url, SV* intl) { _url = url; _intl = intl; _request_attr =  ghttp_request_new(); }
      ~GHTTPUpdate() { ghttp_request_destroy(_request_attr); }

    // set the request type, some random http headers, and the 
    // request URL
      int setRequest(SV* url)
      {
            ghttp_set_type(_request_attr, ghttp_type_get);
            ghttp_set_header(_request_attr, "User-Agent", "GHTTP1/0");
            ghttp_set_header(_request_attr, "Host", "dufus");
            ghttp_set_header(_request_attr, "Accept-Language", "en-gb");
            ghttp_set_header(_request_attr, "Connection", "Keep-Alive");
            return ghttp_set_uri(_request_attr, SvPV(url,SvCUR(url)));
      }

    // process the http request then retrieve the headers, and body 
    //  of the request.  Finally clean out the request object
    // ready for next time
      SV* getRequest()
      {
         char **hdrs;
         int num, rc, i;
         std::string buffer = "";
         ghttp_prepare(_request_attr);
         ghttp_process(_request_attr);
         rc = ghttp_get_header_names(_request_attr, &hdrs, &num);
         for (i=0;i<num;i++){
           buffer.append(hdrs[i], strlen(hdrs[i]));
           buffer.append('\n',1);
	   buffer.append(ghttp_get_header(_request_attr, hdrs[i]));
           free(hdrs[i]);
         };
         buffer.append(ghttp_get_body(_request_attr), ghttp_get_body_len(_request_attr));
         ghttp_clean(_request_attr);
	 return newSVpv(buffer.data(),buffer.length());
      }

    // kick into the timer loop
    // repeat the request at the given interval and then
    // do the callback into perl
      void startTimer (SV* my_self, SV* cback) {

        int result;
        SV* res;
        std::string xml;
        unsigned int intl = SvUV(_intl);
	cerr << "The interval is: " << intl << endl;
	cerr << "The base URL is: " << SvPV(_url,SvCUR(_url)) << endl;

        while (1){
          this->setRequest(_url);
          SV* req = this->getRequest();

          //  Prepare the perl argument stack and 
	  // push the http object and the request content
	  // onto the stack
          dSP;
          ENTER;
          SAVETMPS;
          PUSHMARK(SP);

          // SV of the calling object instance
          XPUSHs(cback);

          // Pointer to the router instance to be plugged into
          //  an object for calling use
          XPUSHs(my_self);

          // Pointer to the current incoming packet
          XPUSHs(req);
          PUTBACK;

	  // Call the base perl routine that will then
	  // call the anonymous sub
          result = perl_call_pv("main::myfancycallback", G_ARRAY | G_EVAL );
          // after the call we can then pull return values back off
	  // the stack
          if(SvTRUE(ERRSV)) fprintf(stderr, "perl call errored: %s", SvPV(ERRSV,PL_na));
          SPAGAIN;
          if ( result > 0 ){
            res = POPs;
          };
          PUTBACK;
          FREETMPS;
          pop_scope();  // is the part of LEAVE that we want

          sleep(intl);
        }
      }

   private:
      SV* _url;
      SV* _intl;
      ghttp_request* _request_attr;
 };


=head1 AUTHOR

Piers Harding - piers@ompa.net

Any questions/suggestions most welcome

=cut





__DATA__

__CPP__


#include <ghttp.h>

using namespace std;

class GHTTPUpdate
{
   public:
      GHTTPUpdate(SV* url, SV* intl) { _url = url; _intl = intl; _request_attr =  ghttp_request_new(); }
      ~GHTTPUpdate() { ghttp_request_destroy(_request_attr); }

      int setRequest(SV* url)
      {
            ghttp_set_type(_request_attr, ghttp_type_get);
            ghttp_set_header(_request_attr, "User-Agent", "GHTTP1/0");
            ghttp_set_header(_request_attr, "Host", "dufus");
            ghttp_set_header(_request_attr, "Accept-Language", "en-gb");
            ghttp_set_header(_request_attr, "Connection", "Keep-Alive");
            return ghttp_set_uri(_request_attr, SvPV(url,SvCUR(url)));
      }

      SV* getRequest()
      {
         char **hdrs;
         int num, rc, i;
         std::string buffer = "";
         ghttp_prepare(_request_attr);
         ghttp_process(_request_attr);
         rc = ghttp_get_header_names(_request_attr, &hdrs, &num);
         for (i=0;i<num;i++){
           buffer.append(hdrs[i], strlen(hdrs[i]));
           buffer.append('\n',1);
	   buffer.append(ghttp_get_header(_request_attr, hdrs[i]));
           free(hdrs[i]);
         };
         buffer.append(ghttp_get_body(_request_attr), ghttp_get_body_len(_request_attr));
         ghttp_clean(_request_attr);
	 return newSVpv(buffer.data(),buffer.length());
      }

      void startTimer (SV* my_self, SV* cback) {


    int result;
    SV* res;
    std::string xml;


        unsigned int intl = SvUV(_intl);
	cerr << "The interval is: " << intl << endl;
	cerr << "The base URL is: " << SvPV(_url,SvCUR(_url)) << endl;

        while (1){
          this->setRequest(_url);
          SV* req = this->getRequest();

          dSP;
          ENTER;
          SAVETMPS;
          PUSHMARK(SP);

          // SV of the calling object instance
          XPUSHs(cback);

          // Pointer to the router instance to be plugged into
          //  an object for calling use
          XPUSHs(my_self);

          // Pointer to the current incoming packet
          XPUSHs(req);

          PUTBACK;
          result = perl_call_pv("main::myfancycallback", G_ARRAY | G_EVAL );

          if(SvTRUE(ERRSV)) fprintf(stderr, "perl call errored: %s", SvPV(ERRSV,PL_na));
          SPAGAIN;
          if ( result > 0 ){
            res = POPs;
          };
          PUTBACK;
          FREETMPS;
          pop_scope();  // is the part of LEAVE that we want

          sleep(intl);
        }
      }

   private:
      SV* _url;
      SV* _intl;
      ghttp_request* _request_attr;
};