File Coverage

lib/WWW/Selenium.pm

Criterion	Covered	Total	%
statement	419	442	94.8
branch	42	66	63.6
condition	10	12	83.3
subroutine	168	171	98.2
pod	152	162	93.8
total	791	853	92.7

# Copyright 2006 ThoughtWorks, Inc
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.
#

package WWW::Selenium;
{
  $WWW::Selenium::VERSION = '1.36';
}
# ABSTRACT: Perl Client for the Selenium Remote Control test tool

use LWP::UserAgent;
use HTTP::Request;
use HTTP::Headers;
use URI::Escape;
use Carp qw(croak);
use Time::HiRes qw(sleep);

use strict;
use warnings;


### This next part is auto-generated based on the big comment in selenium-api.js

#Defines an object that runs Selenium commands.


eval 'require Encode';
my $encode_present = !$@;
Encode->import('decode_utf8') if $encode_present;


sub new {
    my ($class, %args) = @_;
    my $self = { # default args:
                 host => 'localhost',
                 port => 4444,
                 auto_stop => 1,
                 browser_start_command => delete $args{browser} || '*firefox',
                 _ua => undef,
                 keep_alive => 5,
                 http_method => 'POST',
                 %args,
               };
    croak 'browser_url is mandatory!' unless $self->{browser_url};
    croak "Unknown http_method: ($self->{http_method})"
        unless $self->{http_method} =~ m/^GET|POST$/;
    bless $self, $class or die "Can't bless $class: $!";
    return $self;
}

sub start {
    my $self = shift;
    return if $self->{session_id};
    $self->{session_id} = $self->get_string("getNewBrowserSession",
                                            $self->{browser_start_command},
                                            $self->{browser_url});
}

sub stop {
    my $self = shift;
    return unless defined $self->{session_id};
    $self->do_command("testComplete");
    $self->{session_id} = undef;
}

sub do_command {
    my ($self, $command, @args) = @_;
    my $get = $self->{http_method} eq 'GET';

    $self->{_page_opened} = 1 if $command eq 'open';

    # Check that user has called open()
    my %valid_pre_open_commands = (
        testComplete => 1,
        getNewBrowserSession => 1,
        setTimeout => 1,
    );
    if (!$self->{_page_opened} and !$valid_pre_open_commands{$command}) {
        die "You must open a page before calling $command. eg: \$sel->open('/');\n";
    }

    my $fullurl = "http://$self->{host}:$self->{port}/selenium-server/driver/";
    $fullurl .= '?' if $get;
    my $content = '';

    my $i = 1;
    @args = grep defined, @args;
    my $params = $get ? \$fullurl : \$content;
    $$params .= "cmd=" . uri_escape($command);
    while (@args) {
        $$params .= '&' . $i++ . '=' . URI::Escape::uri_escape_utf8(shift @args);
    }
    if (defined $self->{session_id}) {
        $$params .= "&sessionId=$self->{session_id}";
    }
    # We use the full version of LWP to make sure we issue an
    # HTTP 1.1 request (SRC-25)

    my $method = $get ? 'GET' : 'POST';
    print "---> Requesting $method $fullurl ($content)\n" if $self->{verbose};
    my $header = HTTP::Headers->new(
        $get ? () : (
            Content_Type => 'application/x-www-form-urlencoded; charset=utf-8'
        )
    );
    my $response = $self->ua->request(
        HTTP::Request->new($method => $fullurl, $header, $content) );
    my $result;
    if ($response->is_success) {
        $result = $response->content;
        print "Got result: $result\n" if $self->{verbose};
    }
    else {
        die "Error requesting $fullurl:\n" . $response->status_line . "\n";
    }
    $result = decode_utf8($result) if $encode_present;
    die "Error requesting $fullurl:\n$result\n" unless $result =~ /^OK/;
    return $result;
}

sub ua {
    my $self = shift;

    $self->{_ua} ||= LWP::UserAgent->new(keep_alive => $self->{keep_alive});

    if (my $msec = $self->{_timeout}) {
        # Keep the 3 minute timeout (LWP::UserAgent default) on top of the
        # selenium timeout
        $self->{_ua}->timeout( int($msec/1000 + 180) );
    }
    return $self->{_ua};
}

sub get_string {
    my $self = shift;
    my $result = $self->do_command(@_);
    return substr($result, 3);
}

sub get_string_array {
    my $self = shift;
    my $result = $self->get_string(@_);
    my $token = "";
    my @tokens = ();
    my @chars = split(//, $result);
    for (my $i = 0; $i < @chars; $i++) {
        my $char = $chars[$i];
        if ($char eq '\\') {
            $i++;
            $char = $chars[$i];
            $token .= $char;
        } elsif ($char eq ',') {
            push (@tokens, $token);
            $token = "";
        } else {
            $token .= $char;
        }
    }
    push (@tokens, $token);
    return @tokens;
}

sub get_number {
    my $self = shift;
    my $result = $self->get_string(@_);
    # Is there something else I need to do here?
    return $result;
}

sub get_number_array {
    my $self = shift;
    my @result = $self->get_string_array(@_);
    # Is there something else I need to do here?
    return @result;
}

sub get_boolean {
    my $self = shift;
    my $result = $self->get_string(@_);
    if ($result eq "true") {
        return 1;
    }
    if ($result eq "false") {
        return 0;
    }
    die "result is neither 'true' nor 'false': $result";
}

sub get_boolean_array {
    my $self = shift;
    my @result = $self->get_string_array(@_);
    my @boolarr = ();
    for (my $i = 0; $i < @result; $i++) {
        if ($result[$i] eq "true") {
            push (@boolarr, 1);
            next;
        }
        if ($result[$i] eq "false") {
            push (@boolarr, 0);
            next;
        }
        die "result is neither 'true' nor 'false': ". $result[$i];
    }
    return @boolarr;
}


sub pause {
    my ($self,$timeout) = @_;
    $timeout = 1000  unless defined $timeout;
    $timeout /= 1000;
    sleep $timeout;
}

### From here on, everything's auto-generated from XML


sub click {
    my $self = shift;
    $self->do_command("click", @_);
}


sub double_click {
    my $self = shift;
    $self->do_command("doubleClick", @_);
}


sub context_menu {
    my $self = shift;
    $self->do_command("contextMenu", @_);
}


sub click_at {
    my $self = shift;
    $self->do_command("clickAt", @_);
}


sub double_click_at {
    my $self = shift;
    $self->do_command("doubleClickAt", @_);
}


sub context_menu_at {
    my $self = shift;
    $self->do_command("contextMenuAt", @_);
}


sub fire_event {
    my $self = shift;
    $self->do_command("fireEvent", @_);
}


sub focus {
    my $self = shift;
    $self->do_command("focus", @_);
}


sub key_press {
    my $self = shift;
    $self->do_command("keyPress", @_);
}


sub shift_key_down {
    my $self = shift;
    $self->do_command("shiftKeyDown", @_);
}


sub shift_key_up {
    my $self = shift;
    $self->do_command("shiftKeyUp", @_);
}


sub meta_key_down {
    my $self = shift;
    $self->do_command("metaKeyDown", @_);
}


sub meta_key_up {
    my $self = shift;
    $self->do_command("metaKeyUp", @_);
}


sub alt_key_down {
    my $self = shift;
    $self->do_command("altKeyDown", @_);
}


sub alt_key_up {
    my $self = shift;
    $self->do_command("altKeyUp", @_);
}


sub control_key_down {
    my $self = shift;
    $self->do_command("controlKeyDown", @_);
}


sub control_key_up {
    my $self = shift;
    $self->do_command("controlKeyUp", @_);
}


sub key_down {
    my $self = shift;
    $self->do_command("keyDown", @_);
}


sub key_up {
    my $self = shift;
    $self->do_command("keyUp", @_);
}


sub mouse_over {
    my $self = shift;
    $self->do_command("mouseOver", @_);
}


sub mouse_out {
    my $self = shift;
    $self->do_command("mouseOut", @_);
}


sub mouse_down {
    my $self = shift;
    $self->do_command("mouseDown", @_);
}


sub mouse_down_right {
    my $self = shift;
    $self->do_command("mouseDownRight", @_);
}


sub mouse_down_at {
    my $self = shift;
    $self->do_command("mouseDownAt", @_);
}


sub mouse_down_right_at {
    my $self = shift;
    $self->do_command("mouseDownRightAt", @_);
}


sub mouse_up {
    my $self = shift;
    $self->do_command("mouseUp", @_);
}


sub mouse_up_right {
    my $self = shift;
    $self->do_command("mouseUpRight", @_);
}


sub mouse_up_at {
    my $self = shift;
    $self->do_command("mouseUpAt", @_);
}


sub mouse_up_right_at {
    my $self = shift;
    $self->do_command("mouseUpRightAt", @_);
}


sub mouse_move {
    my $self = shift;
    $self->do_command("mouseMove", @_);
}


sub mouse_move_at {
    my $self = shift;
    $self->do_command("mouseMoveAt", @_);
}


sub type {
    my $self = shift;
    $self->do_command("type", @_);
}


sub type_keys {
    my $self = shift;
    $self->do_command("typeKeys", @_);
}


sub set_speed {
    my $self = shift;
    $self->do_command("setSpeed", @_);
}


sub get_speed {
    my $self = shift;
    return $self->get_string("getSpeed", @_);
}


sub check {
    my $self = shift;
    $self->do_command("check", @_);
}


sub uncheck {
    my $self = shift;
    $self->do_command("uncheck", @_);
}


sub select {
    my $self = shift;
    $self->do_command("select", @_);
}


sub add_selection {
    my $self = shift;
    $self->do_command("addSelection", @_);
}


sub remove_selection {
    my $self = shift;
    $self->do_command("removeSelection", @_);
}


sub remove_all_selections {
    my $self = shift;
    $self->do_command("removeAllSelections", @_);
}


sub submit {
    my $self = shift;
    $self->do_command("submit", @_);
}


sub open {
    my $self = shift;
    $_[0] ||= '/'; # default to opening site root

    $self->do_command("open", @_);
}


sub open_window {
    my $self = shift;
    $self->do_command("openWindow", @_);
}


sub select_window {
    my $self = shift;
    $self->do_command("selectWindow", @_);
}


sub select_pop_up {
    my $self = shift;
    $self->do_command("selectPopUp", @_);
}


sub deselect_pop_up {
    my $self = shift;
    $self->do_command("deselectPopUp", @_);
}


sub select_frame {
    my $self = shift;
    $self->do_command("selectFrame", @_);
}


sub get_whether_this_frame_match_frame_expression {
    my $self = shift;
    return $self->get_boolean("getWhetherThisFrameMatchFrameExpression", @_);
}


sub get_whether_this_window_match_window_expression {
    my $self = shift;
    return $self->get_boolean("getWhetherThisWindowMatchWindowExpression", @_);
}


sub wait_for_pop_up {
    my $self = shift;
    local $self->{_timeout} = $_[1];

    $self->do_command("waitForPopUp", @_);
}


sub choose_cancel_on_next_confirmation {
    my $self = shift;
    $self->do_command("chooseCancelOnNextConfirmation", @_);
}


sub choose_ok_on_next_confirmation {
    my $self = shift;
    $self->do_command("chooseOkOnNextConfirmation", @_);
}


sub answer_on_next_prompt {
    my $self = shift;
    $self->do_command("answerOnNextPrompt", @_);
}


sub go_back {
    my $self = shift;
    $self->do_command("goBack", @_);
}


sub refresh {
    my $self = shift;
    $self->do_command("refresh", @_);
}


sub close {
    my $self = shift;
    $self->do_command("close", @_);
}


sub is_alert_present {
    my $self = shift;
    return $self->get_boolean("isAlertPresent", @_);
}


sub is_prompt_present {
    my $self = shift;
    return $self->get_boolean("isPromptPresent", @_);
}


sub is_confirmation_present {
    my $self = shift;
    return $self->get_boolean("isConfirmationPresent", @_);
}


sub get_alert {
    my $self = shift;
    return $self->get_string("getAlert", @_);
}


sub get_confirmation {
    my $self = shift;
    return $self->get_string("getConfirmation", @_);
}


sub get_prompt {
    my $self = shift;
    return $self->get_string("getPrompt", @_);
}


sub get_location {
    my $self = shift;
    return $self->get_string("getLocation", @_);
}


sub get_title {
    my $self = shift;
    return $self->get_string("getTitle", @_);
}


sub get_body_text {
    my $self = shift;
    return $self->get_string("getBodyText", @_);
}


sub get_value {
    my $self = shift;
    return $self->get_string("getValue", @_);
}


sub get_text {
    my $self = shift;
    return $self->get_string("getText", @_);
}


sub highlight {
    my $self = shift;
    $self->do_command("highlight", @_);
}


sub get_eval {
    my $self = shift;
    return $self->get_string("getEval", @_);
}


sub is_checked {
    my $self = shift;
    return $self->get_boolean("isChecked", @_);
}


sub get_table {
    my $self = shift;
    return $self->get_string("getTable", @_);
}


sub get_selected_labels {
    my $self = shift;
    return $self->get_string_array("getSelectedLabels", @_);
}


sub get_selected_label {
    my $self = shift;
    return $self->get_string("getSelectedLabel", @_);
}


sub get_selected_values {
    my $self = shift;
    return $self->get_string_array("getSelectedValues", @_);
}


sub get_selected_value {
    my $self = shift;
    return $self->get_string("getSelectedValue", @_);
}


sub get_selected_indexes {
    my $self = shift;
    return $self->get_string_array("getSelectedIndexes", @_);
}


sub get_selected_index {
    my $self = shift;
    return $self->get_string("getSelectedIndex", @_);
}


sub get_selected_ids {
    my $self = shift;
    return $self->get_string_array("getSelectedIds", @_);
}


sub get_selected_id {
    my $self = shift;
    return $self->get_string("getSelectedId", @_);
}


sub is_something_selected {
    my $self = shift;
    return $self->get_boolean("isSomethingSelected", @_);
}


sub get_select_options {
    my $self = shift;
    return $self->get_string_array("getSelectOptions", @_);
}


sub get_attribute {
    my $self = shift;
    return $self->get_string("getAttribute", @_);
}


sub is_text_present {
    my $self = shift;
    return $self->get_boolean("isTextPresent", @_);
}


sub is_element_present {
    my $self = shift;
    return $self->get_boolean("isElementPresent", @_);
}


sub is_visible {
    my $self = shift;
    return $self->get_boolean("isVisible", @_);
}


sub is_editable {
    my $self = shift;
    return $self->get_boolean("isEditable", @_);
}


sub get_all_buttons {
    my $self = shift;
    return $self->get_string_array("getAllButtons", @_);
}


sub get_all_links {
    my $self = shift;
    return $self->get_string_array("getAllLinks", @_);
}


sub get_all_fields {
    my $self = shift;
    return $self->get_string_array("getAllFields", @_);
}


sub get_attribute_from_all_windows {
    my $self = shift;
    return $self->get_string_array("getAttributeFromAllWindows", @_);
}


sub dragdrop {
    my $self = shift;
    $self->do_command("dragdrop", @_);
}


sub set_mouse_speed {
    my $self = shift;
    $self->do_command("setMouseSpeed", @_);
}


sub get_mouse_speed {
    my $self = shift;
    return $self->get_number("getMouseSpeed", @_);
}


sub drag_and_drop {
    my $self = shift;
    $self->do_command("dragAndDrop", @_);
}


sub drag_and_drop_to_object {
    my $self = shift;
    $self->do_command("dragAndDropToObject", @_);
}


sub window_focus {
    my $self = shift;
    $self->do_command("windowFocus", @_);
}


sub window_maximize {
    my $self = shift;
    $self->do_command("windowMaximize", @_);
}


sub get_all_window_ids {
    my $self = shift;
    return $self->get_string_array("getAllWindowIds", @_);
}


sub get_all_window_names {
    my $self = shift;
    return $self->get_string_array("getAllWindowNames", @_);
}


sub get_all_window_titles {
    my $self = shift;
    return $self->get_string_array("getAllWindowTitles", @_);
}


sub get_html_source {
    my $self = shift;
    return $self->get_string("getHtmlSource", @_);
}


sub set_cursor_position {
    my $self = shift;
    $self->do_command("setCursorPosition", @_);
}


sub get_element_index {
    my $self = shift;
    return $self->get_number("getElementIndex", @_);
}


sub is_ordered {
    my $self = shift;
    return $self->get_boolean("isOrdered", @_);
}


sub get_element_position_left {
    my $self = shift;
    return $self->get_number("getElementPositionLeft", @_);
}


sub get_element_position_top {
    my $self = shift;
    return $self->get_number("getElementPositionTop", @_);
}


sub get_element_width {
    my $self = shift;
    return $self->get_number("getElementWidth", @_);
}


sub get_element_height {
    my $self = shift;
    return $self->get_number("getElementHeight", @_);
}


sub get_cursor_position {
    my $self = shift;
    return $self->get_number("getCursorPosition", @_);
}


sub get_expression {
    my $self = shift;
    return $self->get_string("getExpression", @_);
}


sub get_xpath_count {
    my $self = shift;
    return $self->get_number("getXpathCount", @_);
}


sub assign_id {
    my $self = shift;
    $self->do_command("assignId", @_);
}


sub allow_native_xpath {
    my $self = shift;
    $self->do_command("allowNativeXpath", @_);
}


sub ignore_attributes_without_value {
    my $self = shift;
    $self->do_command("ignoreAttributesWithoutValue", @_);
}


sub wait_for_condition {
    my $self = shift;
    local $self->{_timeout} = $_[1];

    $self->do_command("waitForCondition", @_);
}


sub set_timeout {
    my $self = shift;
    $self->{_timeout} = $_[0];

    $self->do_command("setTimeout", @_);
}


sub wait_for_page_to_load {
    my $self = shift;
    local $self->{_timeout} = $_[1];

    $self->do_command("waitForPageToLoad", @_);
}


sub wait_for_frame_to_load {
    my $self = shift;
    local $self->{_timeout} = $_[1];

    $self->do_command("waitForFrameToLoad", @_);
}


sub get_cookie {
    my $self = shift;
    return $self->get_string("getCookie", @_);
}


sub get_cookie_by_name {
    my $self = shift;
    return $self->get_string("getCookieByName", @_);
}


sub is_cookie_present {
    my $self = shift;
    return $self->get_boolean("isCookiePresent", @_);
}


sub create_cookie {
    my $self = shift;
    $self->do_command("createCookie", @_);
}


sub delete_cookie {
    my $self = shift;
    $self->do_command("deleteCookie", @_);
}


sub delete_all_visible_cookies {
    my $self = shift;
    $self->do_command("deleteAllVisibleCookies", @_);
}


sub set_browser_log_level {
    my $self = shift;
    $self->do_command("setBrowserLogLevel", @_);
}


sub run_script {
    my $self = shift;
    $self->do_command("runScript", @_);
}


sub add_location_strategy {
    my $self = shift;
    $self->do_command("addLocationStrategy", @_);
}


sub capture_entire_page_screenshot {
    my $self = shift;
    $self->do_command("captureEntirePageScreenshot", @_);
}


sub rollup {
    my $self = shift;
    $self->do_command("rollup", @_);
}


sub add_script {
    my $self = shift;
    $self->do_command("addScript", @_);
}


sub remove_script {
    my $self = shift;
    $self->do_command("removeScript", @_);
}


sub use_xpath_library {
    my $self = shift;
    $self->do_command("useXpathLibrary", @_);
}


sub set_context {
    my $self = shift;
    $self->do_command("setContext", @_);
}


sub attach_file {
    my $self = shift;
    $self->do_command("attachFile", @_);
}


sub capture_screenshot {
    my $self = shift;
    $self->do_command("captureScreenshot", @_);
}


sub capture_screenshot_to_string {
    my $self = shift;
    return $self->get_string("captureScreenshotToString", @_);
}


sub capture_entire_page_screenshot_to_string {
    my $self = shift;
    return $self->get_string("captureEntirePageScreenshotToString", @_);
}


sub shut_down_selenium_server {
    my $self = shift;
    $self->do_command("shutDownSeleniumServer", @_);
}


sub retrieve_last_remote_control_logs {
    my $self = shift;
    return $self->get_string("retrieveLastRemoteControlLogs", @_);
}


sub key_down_native {
    my $self = shift;
    $self->do_command("keyDownNative", @_);
}


sub key_up_native {
    my $self = shift;
    $self->do_command("keyUpNative", @_);
}


sub key_press_native {
    my $self = shift;
    $self->do_command("keyPressNative", @_);
}


sub wait_for_text_present {
    my $self = shift;
    $self->do_command("waitForTextPresent", @_);
}


sub wait_for_element_present {
    my $self = shift;
    $self->do_command("waitForElementPresent", @_);
}



sub is_location {
    my $self = shift;
    warn "is_location() is deprecated, use get_location()\n"
        unless $self->{no_deprecation_msg};
    my $expected_location = shift;
    my $loc = $self->get_string("getLocation");
    return $loc =~ /\Q$expected_location\E$/;
}


sub get_checked {
    my $self = shift;
    warn "get_checked() is deprecated, use is_checked()\n"
        unless $self->{no_deprecation_msg};
    return $self->get_string("isChecked", @_) ? 'true' : 'false';
}


sub is_selected {
    my ($self, $locator, $option_locator) = @_;
    warn "is_selected() is deprecated, use get_selected_*() methods\n"
        unless $self->{no_deprecation_msg};
    $option_locator =~ m/^(?:(.+)=)?(.+)/;
    my $selector = $1 || 'label';
    $selector = 'indexe' if $selector eq 'index';
    my $pattern = $2;
    my $func = "get_selected_${selector}s";
    my @selected = $self->$func($locator);
    return grep { $pattern eq $_ } @selected;
}


sub get_selected_options {
    my $self = shift;
    warn "get_selected_options() is deprecated, use get_selected_labels()\n"
        unless $self->{no_deprecation_msg};
    return $self->get_string_array("getSelectedLabels", @_);
}


sub get_absolute_location {
    my $self = shift;
    warn "get_absolute_location() is deprecated, use get_location()\n"
        unless $self->{no_deprecation_msg};
    return $self->get_string("getLocation", @_);
}


sub DESTROY {
    my $self = shift;
    local $@;
    $self->stop if $self->{auto_stop};
}

1;

__END__