plstafservice.pm

Software Testing Automation Framework (STAF)的开发代码

#############################################################################
# Software Testing Automation Framework (STAF)                              #
# (C) Copyright IBM Corp. 2004                                              #
#                                                                           #
# This software is licensed under the Common Public License (CPL) V1.0.     #
#############################################################################

package PLSTAFService;

use 5.008;
use strict;
use warnings;

use threads;
use threads::shared;
use Thread::Queue;

require Exporter;
require PLSTAF;

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 PLSTAFService ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
        
) ] );

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

our @EXPORT = qw(
        
);

our $VERSION = '1.0';
XSLoader::load('PLSTAF', $VERSION);

# Preloaded methods go here.
package STAFServiceInterface;

use 5.008;
use strict;
use warnings;

use threads;
use threads::shared;
                                            
our $funcHash;                              # holds request handling subs
our $requests = Thread::Queue->new();       # holds requests for threads to grab
our $runAThread : shared = 0;               # signal variable
our $numAvailable: shared = 0;              # number of availabe threads
our $ConstructRequest = 1;                  # .
our $InitRequest = 2;                       # .
our $AcceptRequest = 3;                     # constants
our $TermRequest = 4;                       # .
our $DestructRequest = 5;                   # .

# This method gets called by perl services when they are ready to receive 
# requests.  It basically takes a request and passes it to the appropriate
# sub, creating a new thread to handle it if none are available.
sub start()
{
   my $type = shift;
   $funcHash = shift;
   my $serviceName = $funcHash->{serviceName};

   # set up an inbound STAF connection with the name $serviceName
   STAFPerlServiceHelper::initConnection($serviceName);
   
   my %hash : shared;
 
   while(1)
   {

      %hash = %{STAFPerlServiceHelper::getRequest()};

      my $result;
      my $rc = 0;
           
      if ($hash{"reqType"} == $ConstructRequest)
      {
         #$rc = &{ $funcHash->{construct} }();
         
         #STAFPerlServiceHelper::sendResults($hash{reqNum}, $rc, "OK");
         STAFPerlServiceHelper::sendResults($hash{reqNum}, 0, "");
      }
      elsif ($hash{"reqType"} == $InitRequest)
      {
         $rc = &{ $funcHash->{init} }(\%hash);
         
         STAFPerlServiceHelper::sendResults($hash{"reqNum"}, $rc, "");
      }
      elsif ($hash{"reqType"}==$AcceptRequest)
      {
         # XXX: I did this because Perl keeps on dying when I try to enqueue
         # \%hash.  Assigning \%hash to a scalar works for some reason
         my $sharedHash;
         $sharedHash = \%hash;
         
         $requests->enqueue($sharedHash);
         
         # If there are no available threads, create one.
         {
            lock($numAvailable);
            if($numAvailable == 0)
            {
               
               $numAvailable++;
               threads->new(\&requestLoop);
              
               
               #Debug:  If you want to keep track of 
               #        when new threads are created 
               #
               #print "Here are all current threads:\n";
               #for my $t (threads->list()) 
               #{
               #    printf "$t has tid = %d\n", $t->tid();
               #}

            }
         }
         
         # Reduce number of available threads and raise signal
         {
            lock($runAThread);
            lock($numAvailable);
            $numAvailable--;
            $runAThread = 1;
            cond_signal($runAThread);
         }  
      }
      elsif ($hash{"reqType"}==$TermRequest)
      {
         $rc = &{ $funcHash->{term} }(\%hash);

         STAFPerlServiceHelper::sendResults($hash{"reqNum"}, $rc, "");
      }
      elsif ($hash{"reqType"}==$DestructRequest)
      {
         STAFPerlServiceHelper::sendResults($hash{"reqNum"}, 0, "");
      }
    }  
}

# XXX: TMG: Currently, Perl Interpreter Threads don't work particularly well
# with PLSTAF.dll and possibly all XS modules.  It would be much simpler to 
# have perl create a worker thread to handle every request, and have it detach
# from the worker thread. The worker would then be responsible for sending data 
# back the data to staf.  For now we're stuck doing things this way.

# This sub is the loop that the threads run while waiting for work
sub requestLoop {
   while(1)
   {
      my %hash;
      # wait for a signal to wake up
      {
         lock($runAThread);
         while($runAThread != 1)
         {
            cond_wait($runAThread);
         }
         $runAThread = 0;
      }

      # get the request
      %hash = %{$requests->dequeue()};
            
      # handle the request
      my $result = &{ $funcHash->{acceptRequest} }(\%hash);

      # send the results
      STAFPerlServiceHelper::sendResults($hash{"reqNum"}, $result->{rc}, $result->{result});
         
      #now that the thread is done doing it's work, let the parent thread know
      #that it is available again
      {
         lock($numAvailable);
         $numAvailable++;
      }
   }
}

package PLSTAFCommandParser;

sub new {
   my ($self, $obj) = @_;
   bless($obj, 'STAFCommandParser');

   return $obj;
}

package STAFCommandParser;

use constant VALUENOTALLOWED => scalar 0;
use constant VALUEALLOWED    => scalar 1;
use constant VALUEREQUIRED   => scalar 2;

sub parse {
    if ($#_ < 1)
    {
        die 'Usage: $result = STAFCommandParser->parse($request)';
    }

    my ($self, $request) = @_;

    my $obj = {};

    my $result = $self->parseRequest($request);

    $obj->{'rc'}          = $result->rc();
    $obj->{'errorBuffer'} = $result->errorBuffer();
    $obj->{'result'}      = $result;

    bless($obj, 'STAFCommandParseResult');

    return $obj;
}

package STAFCommandParseResult;

sub optionTimes {
    return shift->{'result'}->optionTimes(@_);
}

sub optionValue {
    return shift->{'result'}->optionValue(@_);
}

sub numInstances {
    return shift->{'result'}->numInstances(@_);
}

sub instanceName {
    return shift->{'result'}->instanceName(@_);
}

sub instanceValue {
    return shift->{'result'}->instanceValue(@_);
}

sub numArgs {
    return shift->{'result'}->numArgs(@_);
}

sub arg {
    return shift->{'result'}->arg(@_);
}

1;
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

PLSTAFService - Perl extension for blah blah blah

=head1 SYNOPSIS

  use PLSTAFService;
  blah blah blah

=head1 ABSTRACT

  This should be the abstract for PLSTAFService.
  The abstract is used when making PPD (Perl Package Description) files.
  If you don't want an ABSTRACT you should also edit Makefile.PL to
  remove the ABSTRACT_FROM option.

=head1 DESCRIPTION

Stub documentation for PLSTAFService, created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

=head2 EXPORT

None by default.



=head1 SEE ALSO

Mention other useful documentation such as the documentation of
related modules or operating system documentation (such as man pages
in UNIX), or any relevant external documentation such as RFCs or
standards.

If you have a mailing list set up for your module, mention it here.

If you have a web site set up for your module, mention it here.

=head1 AUTHOR

A. U. Thor, E<lt>[e-mail]<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by A. U. Thor

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

=cut