File Coverage

blib/lib/ExtUtils/Scriptlet.pm

Criterion	Covered	Total	%
statement	29	29	100.0
branch	14	16	87.5
condition	8	10	80.0
subroutine	6	6	100.0
pod	1	1	100.0
total	58	62	93.5

use strict;
use warnings;

package ExtUtils::Scriptlet;

our $VERSION = '1.132640'; # VERSION

# ABSTRACT: run perl code in a new process without quoting it, on any OS

#
# This file is part of ExtUtils-Scriptlet
#
#
# Christian Walde has dedicated the work to the Commons by waiving all of his
# or her rights to the work worldwide under copyright law and all related or
# neighboring legal rights he or she had in the work, to the extent allowable by
# law.
#
# Works under CC0 do not require attribution. When citing the work, you should
# not imply endorsement by the author.
#

use Exporter 'import';
use Data::Dumper;

our @EXPORT_OK = qw( perl );


sub perl {
    my ( $code, %p ) = @_;

    die "No code given" if !$code;

    # no idea why it needs 3, please send a letter if you know, so i can burn it
    $code =~ s/\r\n/\r\r\r\n/g if $^O eq "MSWin32";

    die "at_argv needs to be an array reference" if $p{at_argv} and "ARRAY" ne ref $p{at_argv};
    $p{at_argv} =
      !defined $p{at_argv}
      ? ""
      : sprintf "\@ARGV = \@{ %s };",
      Data::Dumper->new( [ $p{at_argv} || [] ] )->Useqq( 1 )->Indent( 0 )->Dump;

    $p{perl} ||= $^X;
    $p{encoding} = sprintf ":encoding(%s)", $p{encoding} || "UTF-8";
    $p{$_} = defined $p{$_} ? $p{$_} : "" for qw( args argv payload );

    open                                #
      my $fh,                           #
      "|- :raw $p{encoding}",           # :raw protects the payload from write
                                        # mangling (newlines)
      "$p{perl} $p{args} - $p{argv}"    #
      or die "cannot open perl: $!";    #

    print $fh                                    #
      "$p{at_argv};"                             #
      . "binmode STDIN;"                         # protect the payload from read
                                                 # mangling (newlines, system locale)
      . "$code;"                                 # unpack and execute serialized code
      . "\n__END__\n"                            #
      . $p{payload}                              #
      or die "cannot print code to perl: $!";    #

    eval {
        local $SIG{PIPE} = 'IGNORE';             # prevent the host perl from being
                                                 # terminated if the child perl dies
        close $fh or die "cannot close perl: $!";    # grab exit value so we can return it
    };

    return $?;
}

1;


__END__