view release on metacpan or  search on metacpan

Octave.pm  view on Meta::CPAN

#
# now, when perl6 comes out ...
#
sub bind_octave_function
{
   my $o= shift;
   my $oct_funname = shift;
   my $perl_funname = shift;
   my $nargout = shift;
   my $pkg= $o->{API}->{pkg};
   my $code = <<CODE;
package $pkg;
sub $perl_funname {
   # we need to prevent IOM variables from going out of scope
   # in the loop, but rather at the end of the function
   
   #input variables
   my \$inargs=" ";
   my \@vin;
   for (my \$i=0; \$i < \@_; \$i++) {
      \$vin[\$i]= Inline::Octave->new( \$_[\$i] );
      \$inargs.= \$vin[\$i]->name.",";
   }
   chop(\$inargs); #remove last ,

   #output variables
   my \$outargs=" ";
   my \@vout;
   for (my \$i=0; \$i < $nargout; \$i++) {
      \$vout[\$i]= Inline::Octave->new( $retcode_string );
      \$outargs.= \$vout[\$i]->name.",";
   }
   chop(\$outargs); #remove last ,
   \$outargs= "[".\$outargs."]=";
   \$outargs= "" if $nargout==0;

   my \$call= "\$outargs $oct_funname(\$inargs);";
#  print "--\$call--\\n";
   my \$retval= Inline::Octave::interpret(0, \$call );
#  print "--\$retval--\\n";

   # Get the correct size for each new variable
   foreach (\@vout) { \$_->store_size(); }

   return \@vout if wantarray();
   return \$vout[0];
}
CODE
  #print "--$code--\n";
   eval $code;
   croak "Problem binding $oct_funname to $perl_funname: $@" if $@;

   $octave_object->{FUNCS}->{$oct_funname}= $perl_funname;
   return;
}   

sub start_interpreter
{
   my $o = shift;

   # check if interpreter already alive
   return if $octave_object->{OCTIN} and $octave_object->{OCTOUT};

   use IPC::Open3;
   use IO::File;
   my $Oin = new IO::File;
   my $Oout= new IO::File;
   my $Oerr= new IO::File;
   my $pid;
   eval {
      $pid= open3( $Oin , $Oout, $Oerr, $octave_object->{INTERP} );
      # set our priority lower than the kid, so that we don't read each
      # character. Experimentally, I've found 3 to be optimum on Linux 2.4.21
      setpriority 0,0, (getpriority 0,0)+10;
   };
   # ignore errors from setpriority if it's not available
   croak "Can't locate octave interpreter: $@\n" if $@ =~ /Open3/i;

   my $select= IO::Select->new($Oout, $Oerr);

# New idea - start octave with 
# use IPC::Run qw(start);
#  my ($Oin, $Oout, $Oerr);
#  my $pid;
#  eval {
#    $pid= start $octave_object->{INTERP}, \$Oin, \$Oout, \$Oerr
#  };
#  croak "Error starting octave interpreter: $@\n" if $@;

   $octave_object->{octave_pid} = $pid;
   $octave_object->{OCTIN} = $Oin;
   $octave_object->{OCTOUT} = $Oout;
   $octave_object->{OCTERR} = $Oerr;
   $octave_object->{SELECT} = $select;

   # some of this is necessary, some are the defaults
   # but it never hurts to be cautious
   my $startup_code= <<STARTUP_CODE;
crash_dumps_octave_core(0);
page_screen_output(0);
silent_functions(1);
page_screen_output(0);
page_output_immediately(1);
warning( "off", "Octave:fortran-indexing" );
warning( "off", "Octave:empty-list-elements" ); 
more off;
suppress_verbose_help_message(1);
STARTUP_CODE

   $o->interpret( $startup_code ); # check return value?

   return;
}

# we get here from a SIG{CHLD} or a SIG{PIPE}.
# if it's the octave process, then we want to deal
# with it, if it isn't, then we want to pass it to
# the calling processes handler. But how can we
# do that reliably?
#
# instead we just reap any dead processes

sub reap_interpreter
{
#  print "REAP_INTERPRETER\n";
   my $o= $octave_object;
   my $pid= $octave_object->{octave_pid};
   return unless $pid;

   if ( waitpid($pid, WNOHANG) > 0 ) {
       $octave_object->{OCTIN} = "";
       $octave_object->{OCTOUT} = "";
       $octave_object->{octave_pid} = "";
   }

   while (
      ( my $reaped = waitpid (-1, WNOHANG) ) > 0
         ) { };

   return;
}   

sub stop_interpreter
{
   my $o = shift;

   my $Oin= $octave_object->{OCTIN};
   my $Oout= $octave_object->{OCTOUT};

   return unless $Oin and $Oout;

   print $Oin "\n\nexit\n";
   #<$Oin>; #clean up input - is this required?
   close $Oin;
   close $Oout;
   $octave_object->{OCTIN} = "";
   $octave_object->{OCTOUT} = "";
   $octave_object->{octave_pid} = "";
   return;
}   

# send a string to octave and get the result
sub interpret
{
   my $o = shift;
   my $cmd= shift;
   my $marker= $octave_object->{MARKER};

   my $Oin=    $octave_object->{OCTIN};
   my $Oerr=   $octave_object->{OCTERR};
   my $select= $octave_object->{SELECT};
   my $pid   = $octave_object->{octave_pid};

   croak "octave interpreter not alive"  unless $Oin and $Oerr;

#  set SIGnals here, and they will be reset to what the
#  user set them to outside
   local $SIG{CHLD}= \&reap_interpreter;
   local $SIG{PIPE}= \&reap_interpreter;

#  print STDERR "INTERP: $cmd\n";
#  $Oin = "\n\n$cmd\ndisp('$marker');fflush(stdout);\n";
#  $pid->pump() while length $Oin;
   print $Oin "\n\n$cmd\ndisp('$marker');fflush(stdout);\n";

   my $input= '';
   my $marker_len= length( $marker )+1;
   while ( 1 ) {
      for my $fh ( $select->can_read() ) {
          if ($fh eq $Oerr) {
              process_errors();
          } else {

              sysread $fh, (my $line), 16386;
              $input.= $line;
              # delay if we're reading nothing, not sure why select doesn't block
              select undef, undef, undef, 0.5 unless $line;
          }
      }
      last if $input && substr( $input, -$marker_len, -1) eq $marker;

#     $pid->pump();

      process_errors() if $Oerr;
#     select undef, undef, undef, 0.5 unless $line;
#     last if substr( $Oout, -$marker_len, -1) eq $marker;
   }   

   # we need to leave octave blocked doing something,
   # otherwise it can't handle a CTRL-C
   print $Oin "\n\nfread(stdin,1);\n";
   return substr($input,0,-$marker_len);
}

# process any input of stderr
# we assume that we will get a line with
# error: or warning:
sub process_errors
{
   my $Oerr=   $octave_object->{OCTERR};
   my $select= IO::Select->new( $Oerr );

   my $input= "\n";
   # to get full error buffer, wait until we have 100ms with
   # not stderr input
   while ( my @fh = $select->can_read(0.1) ) {
      sysread $fh[0], (my $line), 1024;
      last unless $line;
      $input.= $line;
   }

   #parse input, looking for warning and error patterns
#  print STDERR "#########$input########\n";
   my ($error, $warning);