view release on metacpan or  search on metacpan

lib/Mozilla/Mechanize.pm  view on Meta::CPAN

=cut

sub close {
    my $self = shift;
    $self->agent->quit();
    $self->{agent} = undef;

    # XXX: do we need to run the GUI here?
}

sub open {
    my $self = shift;
    defined $self->{agent} and return;

    my $browser_opts = $self->{_opt};
    $browser_opts->{debug} = $self->{debug};

    $self->{agent} = Mozilla::Mechanize::Browser->new($browser_opts)
      or $self->die("Cannot create a new Browser");

#    foreach my $prop ( keys %{ $self->{_opt} } ) {
#        defined $self->{_opt}{ $prop } and
#            $self->{agent}->{ $prop } = $self->{_opt}{ $prop };
#    }

    return $self;
}

=head2 $moz->agent

Return a reference to the Browser object.

=cut

sub agent { $_[0]->{agent} }


=head1 PAGE-FETCHING METHODS

=head2 $moz->get( $url )

Fetch C<$url>.

=cut

sub get {
    my $self = shift;
    my $agent = $self->agent;
    my ($url) = @_;

    my $uri = $self->uri
        ? URI->new_abs($url, $self->uri->as_string)
        : URI->new($url);

    # XXX: how to add headers?
#    $agent->navigate({ URL     => $uri->as_string,
#                       Headers => $self->_extra_headers($uri) });

    $agent->embedded->load_url($uri->as_string);
    $self->_wait_while_busy;
}

=head2 $moz->reload()

Reload the page.

=cut

sub reload {
    $_[0]->agent->embedded->reload('reloadnormal');
    $_[0]->_wait_while_busy;
}

=head2 $moz->back()

Go back a page in the browser history.

=cut

sub back {
    $_[0]->agent->embedded->go_back;
    $_[0]->_wait_while_busy;
}

=head1 STATUS METHODS

=head2 $moz->success

B<XXX: I don't know how to implement this yet.
So this always returns true for now.>
In fact, if a URL doesn't exist, it'll pop up a dialog. :/

=cut

sub success {
#    $_[0]->agent->ReadyState >= 2;

    # XXX: uh??

    return 1;
}

=head2 $moz->uri

Return the URI of this document (as a URI object).
Note: whenever you do a submit, Mozilla appends a question mark
followed by any form input (name=value pairs separated by ampersands).

=cut

sub uri {
    my $self = shift;
    my $agent = $self->agent;
    my $embed = $agent->embedded;
    my $uri = $embed->get_location;
    URI->new($uri);
}

=head2 $moz->ct

Fetch the content-type of the document.

=cut

sub ct {
    my $self = shift;

    my $doc = $self->get_document;
    my $diid = Mozilla::DOM::NSDocument->GetIID;
    my $nsdoc = $doc->QueryInterface($diid);
    return $nsdoc->GetContentType;
}

=head2 $moz->current_form

Returns the current form as a C<Mozilla::Mechanize::Form> object.

=cut

sub current_form {
    my $self = shift;
    defined $self->{cur_form} or $self->form_number( 1 );

lib/Mozilla/Mechanize.pm  view on Meta::CPAN

=head2 $moz->_extract_images()

Return a list of images.
All images are mapped onto the L<Mozilla::Mechanize::Image|Mozilla::Mechanize::Image>
interface that mimics L<WWW::Mechanize::Image|WWW::Mechanize::Image>.

=cut

{
    # Recursively get image elements. This is necessary in order
    # to preserve their order. Too bad Mozilla doesn't have
    # an `all' method like Internet Explorer.

    my @images;

    sub _extract_images {
        my ($self, $subelement) = @_;
        my $node;

        # The first time, it's called with no subelement
        if (defined $subelement) {
            $node = $subelement;
        } else {
            @images = ();
            $node = $self->get_document_element;
        }

        # If it's an image element, get it; otherwise, recurse if has children
        if ($node->GetNodeName =~ /^(img|input)$/i) {
            my $tagname = lc $1;

            if ($tagname eq 'input') {
                # Element interface is more convenient for attributes
                my $element = $node->QueryInterface(Mozilla::DOM::Element->GetIID);
                # <input> are images only if they have a src
                # (XXX: or maybe should be if type="image"...)
                push @images, Mozilla::Mechanize::Image->new($element, $self)
                  if $element->HasAttribute('src');
                $self->debug("added '$tagname' image");
            } else {
                push @images, Mozilla::Mechanize::Image->new($node, $self);
                $self->debug("added '$tagname' image");
            }
        } elsif ($node->HasChildNodes) {
            my @children = $node->GetChildNodes;
            # skips #text nodes
            foreach my $child (grep {$_->GetNodeName !~ /^#/} @children) {
                $self->_extract_images($child);
            }
        }

        # Continue only at the top-level
        return if defined $subelement;

        $self->{images} = \@images;
        return wantarray ? @{ $self->{forms} } : $self->{forms};
    }
}

=head2 $self->_wait_while_busy()

This adds a "single-shot" idle callback that does Gtk2->main_quit,
then does Gtk2->main. The result is that whenever the UI becomes idle
it will exit the main loop. Thanks to muppet for the idea.
This is repeated until the net_stop event fires, indicating that
the new page has finished loading. (Note therefore that you can only
call this when you expect a new page to load.)

=cut

sub _wait_while_busy {
    my $self = shift;
    my $agent = $self->agent;

    do {
        Glib::Idle->add(sub {
            Gtk2->main_quit;
            FALSE;  # uninstall
        }, undef, G_PRIORITY_LOW);
        Gtk2->main;
    } until $agent->{netstopped};

    $self->{$_} = undef for qw(forms cur_form links images);
    return $self->success;
}

=head2 warn( @messages )

Centralized warning method, for diagnostics and non-fatal problems.
Defaults to calling C<CORE::warn>, but may be overridden by setting
C<onwarn> in the construcotr.

=cut

sub warn {
    my $self = shift;

    return unless my $handler = $self->{onwarn};

    return if $self->quiet;

    $handler->(@_);
}

=head2 die( @messages )

Centralized error method.  Defaults to calling C<CORE::die>, but
may be overridden by setting C<onerror> in the constructor.

=cut

sub die {
    my $self = shift;

    return unless my $handler = $self->{onerror};

    $handler->(@_);
}

# Not a method
sub __warn {

    eval "require Carp";
    if ( $@ ) {
        CORE::warn @_;
    } else {
        &Carp::carp;
    }
}

# Not a method