view release on metacpan or  search on metacpan

bin/mcp-fs  view on Meta::CPAN

      return if $lines and $line_truncated;
      return unless length $data;
      my $remaining = $byte_limit - (length $stdout) - (length $stderr);
      $truncated = 1 if length $data > $remaining;
      $$target .= substr $data, 0, $remaining
         if $remaining > 0;

      if ($lines and $line_limit and ($$target =~ tr/\n//) > $line_limit) {
         my $end = -1;
         $end = index $$target, "\n", $end + 1
            for 1 .. $line_limit;
         substr $$target, $end + 1, length $$target, "";
         $truncated = $line_truncated = 1;
         return 1
      }

      0
   };

   proc_run $req, $command, $input, $timeout,
      sub {
         my ($handle) = @_;
         my $stop = $capture->(\$stdout, $handle->{rbuf}, 1);
         $handle->{rbuf} = "";
         $stop
      },
      sub {
         my ($handle) = @_;
         $capture->(\$stderr, $handle->{rbuf}, 0);
         $handle->{rbuf} = "";
         0
      },
      sub {
         my ($status, $timed_out, $failure) = @_;
         return $done->(0, $failure) if $failure;
         $done->(1, +{
            stdout    => $stdout,
            stderr    => $stderr,
            exit      => $status >> 8,
            signal    => $status & 127,
            timed_out => $timed_out ? JSON::XS::true : JSON::XS::false,
            truncated => $truncated || $timed_out ? JSON::XS::true : JSON::XS::false,
         });
      };
}

my $perl_slave = q{#perl
   binmode STDIN;
   binmode STDOUT;
   $SIG{PIPE} = "IGNORE";
   $| = 1;

   for (;;) {
      4 == read STDIN, my $buf, 4
         or last;
      my $len = unpack "N", $buf;
      $len == read STDIN, $buf, $len
         or die "short perl frame\n";

      my @result = do {
         (my $source, local @ARGV) = unpack "(w/a*)*", $buf;
         ("+", eval $source)
      };

      @result = ("-", $@)
         if $@;

      print pack "N/a*", pack "(w/a*)*", @result
         or die "stdout: $!\n"
   }
};

sub perl_frame {
   pack "N/a*", pack "(w/a*)*", @_
}

my $perl_worker;

sub perl_eval {
   my ($req, $workdir, $sandbox_grants, $source, $args, $timeout, $done) = @_;

   my @command = ((fs_sandbox $workdir, $sandbox_grants), $perl, "-e", $perl_slave);
   my $key = pack "(w/a*)*", @command;
   my $io = $perl_worker;
   undef $perl_worker;

   if ($io && ($io->{perl_key} ne $key || !$io->{proc}{pid})) {
      proc_destroy $io;
      undef $io;
   }

   unless ($io) {
      $io = proc_spawn @command;
      $io->{rbuf_max} = (1 << 20) + 4096;
      $io->{perl_key} = $key;
      weaken (my $this = $io);

      my $idle_destroy = sub {
         my $io = $this or return;

         undef $perl_worker if $perl_worker && $perl_worker == $io;
         proc_destroy $io;
      };
      my $idle_stderr = sub { $_[0]{rbuf} = "" };

      $io->{perl_idle} = sub {
         my ($io) = @_;
         my $err = $io->{proc_err};

         $io ->on_eof   ($idle_destroy);
         $io ->on_error ($idle_destroy);
         $err->on_eof   ($idle_destroy);
         $err->on_error ($idle_destroy);
         $err->on_read  ($idle_stderr );
         $io ->on_read  ($idle_destroy);
      };

      proc_on_exit $io->{proc}, sub {
         my $io = $this or return;

         $io->{perl_on_exit}->($_[0]) if $io->{perl_on_exit};