File Coverage

blib/lib/RPC/Simple/Factory.pm

Criterion	Covered	Total	%
statement	123	145	84.8
branch	22	40	55.0
condition	8	27	29.6
subroutine	19	21	90.4
pod	8	9	88.8
total	180	242	74.3

package RPC::Simple::Factory;

use strict;
use warnings ;
use vars qw(@ISA @EXPORT $VERSION $serverPid);
use IO::Socket ;
use Fcntl ;
use Data::Dumper ;
use Carp ;

require Exporter;

( $VERSION ) = '$Revision: 1.9 $ ' =~ /\$Revision:\s+([^\s]+)/;

@ISA = qw(Exporter);
@EXPORT= qw(spawn) ;
# 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.

# Preloaded methods go here.

# As a test may control several machines, several Factory object may be created

# opens a connection to a remote host
# Tk top window, remote_host, port
sub new
  {
    my $type = shift ;

    my ($tkTop,$verboseRef,$remote,$port,$timeout);

    if (ref $_[0])
      {
	# old style api
	$tkTop = shift ;
	$verboseRef = shift ;
	$remote  = shift || 'localhost';
	$port    = shift || 7810;
	$timeout = shift || 0 ;
      }
    else
      {
	# new style
	my %args = @_ ;

	$tkTop      = $args{tk_top};
	$verboseRef = $args{verbose_ref} ;
	$remote     = $args{remote_host} || 'localhost';
	$port       = $args{remote_port} || '7810' ;
	$timeout    = $args{timeout}     || 0 ;
      }

    my $self = {
		verbose => $verboseRef,
		handleIdx => 0,
		remoteHostName => $remote
	       };

    my ($iaddr, $paddr, $proto, $line);

    if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }

    print "No port" unless $port;

    my @time_arg = $timeout ? (Timeout => $timeout) : () ;
    $self->{'socket'} = IO::Socket::INET -> new (PeerAddr => $remote,
						 PeerPort => $port,
						 Proto => 'tcp',
						 @time_arg) ;

    die "Can't create a socket for $remote, port $port\n\t$!\n"
      unless defined $self->{'socket'} ;

    fcntl($self->{'socket'},F_SETFL, O_NDELAY)
      || die "fcntl failed $!\n";

    print "$type object created \n";

    # print "sleep over, closing\n";
    # shutdown ($self->{'socket'}, 2)            || print "close: $!";

    bless $self, $type ;

    if (defined $tkTop)
      {
	# register socket to TK's fileevent ...
	$tkTop -> fileevent($self->{'socket'},
			    'readable' => [$self, 'readSock']) ;
	$self->{tkTop} = $tkTop ;
      }

    $self->{sockBuffer} = '' ;
    return $self ;
  }

sub DESTROY
  {
    my $self = shift ;
    print "closing Factory socket\n";

    # de-register from Tk
    $self->{tkTop} -> fileevent($self->{'socket'},readable => '')
      if defined $self->{tkTop} ;

    #$self->{socket}->close;
    if(defined $self->{socket} && $self->{socket}->connected)
      {
        shutdown($self->{socket},2) ;
      }
  }

sub logmsg
  {
    my $self = shift ;

    print @_ if (defined $self->{verbose} and ${$self->{verbose}} );
}

sub newRemoteObject
  {
    my $self=shift ;
    my $clientRef = shift ;
    my $remoteClass = shift ; #optionnal

    # create an Agent tied to the client object
    my $handle = RPC::Simple::Agent->new ($self,$clientRef,$self->{handleIdx},
                                          $remoteClass,@_) ;

    $self->{handleTab}{$self->{handleIdx}++} = $handle ;
    return $handle ;
  }

sub destroyRemoteObject
  {
    my $self=shift ;
    my $idx = shift ;
    $self->writeSockBuffer($idx, 'destroy' );
    delete $self->{handleTab}{$idx} ;
  }

sub getRemoteHostName
  {
    my $self=shift ;
    return $self->{remoteHostName} ;
  }

sub writeSockBuffer
  {
    my $self=shift ;
    my $callingIdx = shift ;    # index of Agent
    my $method = shift ;
    my $reqId = shift ;
    my $param = shift  ;        # usually an array ref
    my $objectName = shift ;    # optionnal

    my $refs = [$param,$method,$reqId, $callingIdx ] ;
    my $names = ['args','method','reqId','handle',] ;

    if (defined $objectName)
      {
        push @$refs, $objectName ;
        push @$names, 'objectName' ;
      }

    my $d = Data::Dumper->new ( $refs, $names ) ;
    my $paramStr = "#begin\n".$d->Dumpxs."#end\n"  ;
    #my $str = sprintf("%6d",length($paramStr)) . $paramStr ;
    my $str = $paramStr ;
    $self->logmsg( "$str\n");

    $self->{sockBuffer} .= $str ;

    my $str2 = "#begin_buffer\n".$self->{sockBuffer}."#end_buffer\n" ;
    no strict 'refs' ;
    my $val = send($self->{'socket'} ,$str2,0) ;
    if ( defined $val and $val == length($str2))
      {
        $self->logmsg( "$val bytes sent\n");
      }
    else
      {
        warn "write failed for \n",$str2  ;
      }

    $self->{sockBuffer} = '' ;
  }

sub readSock
  {
    my $self = shift ;

    my $fh = $self->{'socket'} ;

    $self->logmsg( "readSock called\n");
    no strict 'refs' ;

    if (eof $fh)
      {
        #print "closing connection\n";
        #close $fh ;
        return 0;
      }

    my $line ;
    my @codeTab = () ;
    my $code = '' ;
    my $codeEnd = 1 ;
    while ( $line = $fh->getline or not $codeEnd )
      {
        next unless defined $line ;

        $self->logmsg( "->",$line );
        $code .= $line ;

        if ($line =~ /\s*#end$/)
          {
            push @codeTab, $code ;
            $code = '' ;
            $codeEnd = 1 ;
          }
        if ($line =~ /\s*#begin$/
           )
          {
            $codeEnd = 0 ;
          }
      }

    use strict ;

    foreach $code (@codeTab)
      {
	# these lexical variables are assigned in the eval
        my ($args,$method,$reqId,$handle,$objectName) ;
        eval $code ;

        if ($@)
          {
            print "failed eval ($@) of :\n",$code,"end evaled code\n"  ;
          }
        elsif (defined $method)
          {
            # call object method directly
            $self->logmsg( "calling method $method\n");
            $self->{handleTab}{$handle} -> callMethod($method , $args) ;
          }
	else
          {
            # it's a call-back
            $self->logmsg( "callback for handle $handle, request $reqId\n");
            $self->{handleTab}{$handle}->treatCallBack($reqId, $args);
            #			  or print "eval failed: $@\n";
          }
      }
    return 1;
  }

# static method. spawn a server
sub spawn
  {
    my $port = shift ;
    my $verbose = shift ;

    $serverPid = fork ;

    if ($serverPid == 0)
      {
        # I am a server now
        RPC::Simple::Server::mainLoop ($port,$verbose) ;
        exit ; # well I should never go there
      }
    print "spawned server pid $serverPid\n" ; # don't use verbose
    sleep 2 ; # let the server start
    return $serverPid ;
  }

sub getSocket
  {
    my $self = shift;
    return $self->{socket};
  }

sub END
  {
     if (defined $serverPid and $serverPid != 0 )
       {
         print "killing process $serverPid\n";
         # 15 is SIGTERM signal
         kill (15, $serverPid) ;
       }
  }

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__