File Coverage

blib/lib/Playwright.pm

Criterion	Covered	Total	%
statement	121	254	47.6
branch	15	78	19.2
condition	14	50	28.0
subroutine	29	42	69.0
pod	8	8	100.0
total	187	432	43.2

package Playwright;
$Playwright::VERSION = '1.551';
use strict;
use warnings;

#ABSTRACT: Perl client for Playwright
use 5.006;
use v5.28.0;    # Before 5.006, v5.10.0 would not be understood.

use constant IS_WIN => $^O eq 'MSWin32';

use File::ShareDir();
use File::Basename();
use Cwd();
use LWP::UserAgent();
use Sub::Install();
use Net::EmptyPort();
use JSON::MaybeXS();
use File::Which();
use File::Temp();
use Capture::Tiny qw{capture_merged capture_stderr};
use Carp          qw{confess};

use Playwright::Base();
use Playwright::Util();

# Stuff closet full of skeletons at BEGIN time
use Playwright::ModuleList();

no warnings 'experimental';
use feature qw{signatures};

our ( $spec, $server_bin, $node_bin, %mapper );

sub _check_node {

    # Check that node is installed
    $node_bin = File::Which::which('node');
    confess("node must exist, be in your PATH and executable")
      unless $node_bin && -x $node_bin;

    # Make sure it's possible to start the server
    $server_bin = File::Which::which('playwright_server');

    # If it's not in $PATH, it should be in ../bin
    $server_bin //= Playwright::Util::find_playwright_server();

    confess(
        "Can't locate playwright_server!
    Please ensure it is installed in your PATH.
    If you installed this module from CPAN, it should already be."
    ) unless $server_bin && -x $server_bin;

    $server_bin = Cwd::abs_path($server_bin);

    # Attempt to start the server.  If we can't do this, we almost certainly have dependency issues.
    my $output = '';
    if (IS_WIN) {
        $output = 'OK';
    }
    else {
        ($output) =
          capture_merged { system( $node_bin, $server_bin, '--check' ) };
    }
    return if $output =~ m/OK/;

    warn $output if $output;

    confess(
        "playwright_server could not run successfully.
    See the above error message for why.
    It's likely to be unmet dependencies, or a NODE_PATH issue.

    Install of node dependencies must be done manually.
    Run the following:

    npm i express playwright uuid
    sudo npx playwright install-deps
    export NODE_PATH=\"\$(pwd)/node_modules\".

    If you still experience issues, run the following:

    NODE_DEBUG=module playwright_server --check

    This should tell you why node can't find the deps you have installed.
    "
    );

}

sub _build_classes {
    foreach my $class ( keys(%$spec) ) {
        $mapper{$class} = sub {
            my ( $self, $res ) = @_;
            my $class = "Playwright::$class";
            return $class->new(
                handle => $self,
                id     => $res->{_guid},
                type   => $class,
                parent => $self,
            );
        };
    }
}

sub BEGIN {
    our $SKIP_BEGIN;
    _check_node() unless $SKIP_BEGIN;
}

sub new ( $class, %options ) {

    #XXX yes, this is a race, so we need retries in _start_server
    my $port    = $options{port}    // Net::EmptyPort::empty_port();
    my $cdp_uri = $options{cdp_uri} // '';
    my $timeout = $options{timeout} // 30;
    $options{maxrequest} //= '100kb';
    my $cleanup =
      ( $options{cleanup} // !( $options{port} || $options{host} ) ) ? 1 : 0;
    my $self = bless(
        {
            ua      => $options{ua}   // LWP::UserAgent->new(),
            host    => $options{host} // 'localhost',
            port    => $port,
            cdp_uri => $cdp_uri,
            debug   => $options{debug},
            cleanup => $cleanup,
            pid     => $options{host} ? "REUSE" : _start_server(
                $port, $cdp_uri, $timeout, $options{debug}, $cleanup
            ),
            parent  => $$ // 'bogus',    # Oh lawds, this can be undef sometimes
            timeout => $timeout,
        },
        $class,
    );

    $self->_check_and_build_spec();
    _build_classes();

    # Control things about the environment we start pw in
    $ENV{MAX_REQUEST_SIZE} = $options{maxrequest};

    return $self;
}

sub _check_and_build_spec ($self) {
    return $spec if ref $spec eq 'HASH';

    $spec =
      Playwright::Util::request( 'GET', 'spec', $self->{host}, $self->{port},
        $self->{ua}, );

    confess(
        "Could not retrieve Playwright specification.  Check that your playwright installation is correct and complete."
    ) unless ref $spec eq 'HASH';
    return $spec;
}

sub launch ( $self, %args ) {

    Playwright::Base::_coerce(
        $spec->{BrowserType}{members},
        args    => [ \%args ],
        command => 'launch'
    );
    delete $args{command};

    my $msg = Playwright::Util::request(
        'POST', 'session', $self->{host}, $self->{port}, $self->{ua},
        type => delete $args{type},
        args => [ \%args ]
    );

    return $Playwright::mapper{ $msg->{_type} }->( $self, $msg )
      if ( ref $msg eq 'HASH' )
      && $msg->{_type}
      && exists $Playwright::mapper{ $msg->{_type} };
    return $msg;
}

sub server ( $self, %args ) {
    return Playwright::Util::request(
        'POST', 'server', $self->{host}, $self->{port}, $self->{ua},
        object  => $args{browser}{guid},
        command => $args{command},
    );
}

sub await ( $self, $promise ) {
    my $obj = Playwright::Util::await($promise);

    return $obj unless $obj->{_type};
    my $class = "Playwright::$obj->{_type}";
    return $class->new(
        type   => $obj->{_type},
        id     => $obj->{_guid},
        handle => $self
    );
}

sub pusht ( $object, $timeout, $navigation = 0 ) {
    $object->{timeouts} //= [];
    push( @{ $object->{timeouts} }, $timeout );
    return $object->setDefaultNavigationTimeout($timeout) if $navigation;
    return $object->setDefaultTimeout($timeout);
}

sub popt ( $object, $navigation = 0 ) {
    $object->{timeouts} //= [];
    my $last_timeout = pop( @{ $object->{timeouts} } ) // 1000;
    return $object->setDefaultNavigationTimeout($last_timeout) if $navigation;
    return $object->setDefaultTimeout($last_timeout);
}

sub try_until ( $object, $method, @args ) {
    my ( $ctr, $result, $timeout ) = (0);
    $timeout = $object->{timeouts}[-1] if ref $object->{timeouts} eq 'ARRAY';
    $timeout = $timeout / 1000         if $timeout;
    $timeout //= 1;
    while ( !$result ) {
        $result = $object->$method(@args);
        last if $result;
        sleep 1;
        $ctr++;
        last if $ctr >= $timeout;
    }
    return $result;
}

sub quit ($self) {

    # Prevent double destroy after quit()
    return if $self->{killed};

    # Prevent destructor from firing in child processes so we can do things like async()
    # This should also prevent the waitpid below from deadlocking due to two processes waiting on the same pid.
    my $ppid = $$ // 'hokum'
      ;    # If $$ is undef both here and in the parent, let's just keep going
    return unless $ppid == $self->{parent};

    # Prevent destructor from firing in the event the caller instructs it to not fire
    return unless $self->{cleanup};

    # Make sure we don't mash the exit code of things like prove
    local $?;

    $self->{killed} = 1;
    print "Attempting to terminate server process...\n" if $self->{debug};

    # Best effort to whack this, we can't make guarantees during global destruction
    eval {
        capture_merged {
            Playwright::Util::request( 'GET', 'shutdown', $self->{host},
                $self->{port}, $self->{ua} )
        };
    } if $self->{ua};

    return $self->_kill_playwright_server_windows() if IS_WIN;

    # 0 is always WCONTINUED, 1 is always WNOHANG, and POSIX is an expensive import
    # When 0 is returned, the process is still active, so it needs more persuasion
    foreach ( 0 .. 3 ) {
        return unless waitpid( $self->{pid}, 1 ) == 0;
        sleep 1;
    }

    # Advanced persuasion
    print "Forcibly terminating server process...\n" if $self->{debug};
    kill( 'TERM', $self->{pid} );

    #XXX unfortunately I can't just do a SIGALRM, because blocking system calls can't be intercepted on win32
    foreach ( 0 .. $self->{timeout} ) {
        return unless waitpid( $self->{pid}, 1 ) == 0;
        sleep 1;
    }
    warn "Could not shut down playwright server!";
    return;
}

sub DESTROY ($self) {
    $self->quit();
}

sub _wait_port ( $port, $timeout, $debug ) {

    #XXX unusedvars is wigging
    $debug = $debug;
    my $result;
    $result = $result;

    # Check if the port is already live, and short-circuit if this is the case.
    if (IS_WIN) {
        for ( 0 .. $timeout ) {
            $result = qx{netstat -na | findstr "$port"};
            print "Waiting on port $port: $result\n" if $debug;
            last                                     if $result;
            sleep 1;
        }
        return !!$result;
    }
    return Net::EmptyPort::wait_port( $port, $timeout );
}

sub _start_server ( $port, $cdp_uri, $timeout, $debug, $cleanup ) {
    $debug = $debug ? '--debug' : '';

    # Check if the port is already live, and short-circuit if this is the case.
    if ( _wait_port( $port, 1, $debug ) ) {
        print "Re-using playwright server on port $port...\n" if $debug;

        # Set the PID as something bogus, we don't really care as we won't kill it
        return "REUSE";
    }

    # On windows, the args will have to be handled slightly differently.
    my @args;
    if (IS_WIN) {
        push( @args, qq{"$node_bin"}, qq{"$server_bin"} );
    }
    else {
        push( @args, $node_bin, $server_bin );
    }

    push( @args, ( "--port", $port ) );
    push( @args, "--cdp", $cdp_uri ) if $cdp_uri;
    push( @args, $debug ) if $debug;

    $ENV{DEBUG} = 'pw:api' if $debug;
    return _start_server_windows( $port, $timeout, $debug, $cleanup, @args )
      if IS_WIN;
    my $pid = fork // confess("Could not fork");
    if ($pid) {
        print "Waiting for playwright server on port $port to come up...\n"
          if $debug;
        Net::EmptyPort::wait_port( $port, $timeout )
          or confess( "Server never came up after " . $timeout . "s!" );
        print "done\n" if $debug;

        return $pid;
    }

    # Orphan the process in the event that cleanup => 0
    if ( !$cleanup ) {
        print "Detaching child process...\n";
        chdir File::Temp::tempdir( CLEANUP => 1 );
        require POSIX;
        die "Cannot detach playwright_server process for persistence"
          if POSIX::setsid() < 0;
        require Capture::Tiny;
        capture_merged { exec(@args) };
        die("Could not exec!");
    }
    exec(@args);
}

sub _start_server_windows ( $port, $timeout, $debug, $cleanup, @args ) {
    my $pid       = qq/playwright-server:$port/;
    my @cmdprefix = ( "start /MIN", qq{"$pid"} );

    # Test::UnusedVars hack
    $cleanup = '';

    my $cmdstring = join( ' ', @cmdprefix, @args );
    print "$cmdstring\n" if $debug;
    system($cmdstring);
    _wait_port( $port, $timeout, $debug );
    return $pid;
}

sub _kill_playwright_server_windows ($self) {
    my $killer = qq[taskkill /FI "WINDOWTITLE eq $self->{pid}"];
    print "$killer\n" if $self->{debug};
    system($killer);
    return 1;
}

1;

__END__