File Coverage

blib/lib/Serengeti/Context.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Serengeti::Context;

use strict;
use warnings;

use File::Basename qw();
use File::Spec;
use JavaScript;
use List::Util qw(first);
use Module::Load qw();
use Scalar::Util qw(blessed);
use Regexp::Common qw(URI);

use Serengeti;
use Serengeti::NotificationCenter;
use Serengeti::Notifications;
use Serengeti::Util qw(trim);

use accessors::ro qw(js_ctx search_paths backend callbacks session windows);

{
    my $JSRuntime;
    sub shared_js_runtime {
        return $JSRuntime if $JSRuntime;

        $JSRuntime = JavaScript::Runtime->new();

        return $JSRuntime;
    }
}

sub new {
    my ($pkg, $args) = @_;

    my $ctx = shared_js_runtime->create_context();

    my $backend = $args->{backend} || $Serengeti::DefaultBackend;
    Module::Load::load $backend;

    my $self = bless {
        js_ctx          => $ctx,
        search_paths    => ["."],
        backend         => $backend->new,
        callbacks       => {},
        session         => undef,
    }, $pkg;

    $self->_setup_jsapi();

    return $self;
}

sub register_callback {
    my ($self, $name, $callback) = @_;

    $self->callbacks->{$name} = $callback;
}

sub _setup_jsapi {
    my $self = shift;

    my $ctx = $self->js_ctx;

    my $common = {
        include => sub {
            my $path = shift;

            # We can actually include remote files which contains
            # stuff that the website needs
            if ($path =~ $RE{URI}{HTTP}) {
                my $response = $self->backend->get($path);
                if ($response->is_success) {
                    $ctx->eval($response->decoded_content);
                    if ($@) {
                        warn $@;
                    }
                }

                return;
            }

            $self->load($path);
        },
        gimme => sub {
            my $name = pop;
            #     $self->session->log_action("requested data", @_);
            die "Missing data request name" unless defined $name;
            # Calls a registered perl function to retrieve stuff like
            # passwords which might not want to be sent as args
            my $callback = $self->callbacks->{$name};
            die "Missing callback for '${name}'" unless $callback;
            return $callback->(@_);
        },
        get => sub {
            $self->backend->get(@_);
        },
        post => sub {
            $self->backend->post(@_);
        },
        head => sub {
            $self->backend->get(@_);
        },
        log    => sub {
            # This should tell the session object to log an entry
            print STDERR join("", @_), "\n";
        },
        match => \&match,
    };

    $self->backend->setup_document_jsapi($self->js_ctx);
    $self->backend->setup_window_jsapi($self->js_ctx);

    $ctx->bind_object('$Browser' => $common);

    # Listen to when we get new documents
    Serengeti::NotificationCenter->add_observer(
        $self,
        selector    => "document_changed",
        for         => DOCUMENT_CHANGED_NOTIFICATION,
        from        => $self->backend,
    );

    Serengeti::NotificationCenter->add_observer(
        $self,
        selector    => "session_changed",
        for         => NEW_SESSION_NOTIFICATION,
    );

    Serengeti::NotificationCenter->add_observer(
        $self,
        selector    => "log_session_event",
        for         => SESSION_EVENT_NOTIFICATION,
        from        => $self->backend,
    );

    1;
}

sub DESTROY {
    my $self = shift;
    Serengeti::NotificationCenter->remove_observer($self);
}

sub load {
    my ($self, $file) = @_;

    my $path;
    my @inc = @{$self->search_paths};

    for my $dir (@inc) {
        my $lp = File::Spec->catfile($dir, $file);
        $path = $lp, last if -e $lp;
    }

    die "Can't find file: $file" unless $path;

    my $dirname = File::Basename::dirname($path);

    # Temporary add the file's basename to the list of directories to search.
    my $inc = $self->search_paths;
    my @new_inc = @$inc;
    push @new_inc, $dirname unless first { $_ eq $dirname } @new_inc;
    local $self->{search_paths} = \@new_inc;

    $self->js_ctx->eval_file($path);

    die "$@" if $@;
}

sub has_action {
    my ($self, $action) = @_;

    return $self->js_ctx->can($action);
}

sub invoke_action {
    my ($self, $action, $args, $options) = @_;

    $args = {} unless ref $args eq "HASH";
    $options = {} unless ref $args eq "HASH";

    return $self->js_ctx->call($action, $args, $options);
}

sub eval {
    my ($self, $source, $filename, $lineno) = @_;

    return $self->js_ctx->eval($source, $filename, $lineno);
}

sub session_changed {
    my ($self, $sender, $notification, $data) = @_;

    $self->{session} = $data;
}

sub document_changed {
    my ($self) = @_;
    $self->js_ctx->unbind_value("document");
    $self->js_ctx->bind_object(document => $self->backend->current_document);
    1;
}

sub log_session_event {
    my ($self, $sender, $notification, $data) = @_;
    if ($self->session) {
        my ($action, $event_args) = @{$data}{qw(event data)};
        $event_args = [] unless ref $event_args eq "ARRAY";
        $self->session->log_event($action, @$event_args);
    }
}

sub match {
    my $self = shift;

    my $content;
    if (ref $_[0] eq "Regexp") {
        # Default to document.body.innerHTML;
        $content = $self->backend->current_document->get_body->as_HTML;
    }
    else {
        $content = shift;
        if (blessed $content && $content->isa("HTML::Element")) {
            $content = $content->as_HTML;
        }
    }

    my $re = shift;
    $re = qr/$re/ unless ref $re eq "Regexp";

    my $options = shift;
    $options = {} unless ref $options eq "HASH";

    # Perform matching
    my $matches = 0;

    my $session = $self->session;
    my $stash = $session ? $session->stash : undef;

    my @set;
    if (defined $options->{set} && $stash) {
        @set = map trim, split /\s*,\s*/, $options->{set};

        delete @{$stash}{@set} if $stash;
    }

    my %set;
    while (my @matches = ($content =~ $re)) {
        $content =~ s/$re//;
        $matches++;

        for my $key (@set) {
            my $v = shift @matches;
            if (ref $stash->{$key} eq "ARRAY") {
                push @{$stash->{$key}}, $v;
            }
            elsif (exists $stash->{$key}) {
                $stash->{$key} = [delete $stash->{$key}, $v];
            }
            else {
                $stash->{$key} = $v;
            }
        }
    }

    if (exists $options->{strict}) {
        my $expect_matches = $options->{strict} || 0;
        if ($matches != $expect_matches) {
            die "Match matches ", $matches, " time(s) instead of required ",
                ${expect_matches}, " time(s)";
        }
    }

    return $matches;
}

1;
__END__