Re: Mech JS support
Father Chrysostomos <[email protected]>
| Newsgroups | gmane.comp.lang.perl.modules.lwp |
|---|---|
| Message-ID | <[email protected]> |
On Jul 19, 2007, at 12:19 AM, Eric Wilhelm wrote:
> # from Father Chrysostomos
> # on Wednesday 18 July 2007 10:26 pm:
>
>> for everyone’s perusal.
>
> I'm seeing this a lot.
>
> + $self->_extract_forms() unless $self->{_extracted_forms};
>
> Given that it is a void-context and is a noop if _extracted_forms is
> false, why not just put
>
> return unless $self->{_extracted_forms}
I hope you mean 'if', as opposed to 'unless'. :-)
>
> inside the _extract_forms() method?
In the current_form and forms methods, I'm trying to follow the style
of the existing code (see the links method, for instance). I'll
change it if Andy says to.
But I do agree that it is redundant to repeat this line elsewhere.
And in a couple of cases (form_name and form_with_fields) it was
completely unnecessary. Thank you for catching this.
In the remaining cases, I can change $self->{form} to $self-
>current_form and $self->{forms} to $self->forms.
>
> Also, I would guess that separate init() and options() methods
> would be
> preferable in writing plugins rather than having init() handle options
> and self but options() gets just options. Similarly, the init() call
> should get $self as the first parameter such as:
>
> my $plugin_init = "WWW::Mechanize::Plugin::$plugin" . '::init';
> $self->$plugin_init()
>
> And similarly for $self->$plugin_options(@opts).
>
> That is, unless the plugin is an object, which maybe it should be.
Which is what I intended. I think your idea of keeping init and
options separate, such that init never gets options is good and makes
the interface cleaner. How about this:
($plugins->{$plugin} =
"WWW::Mechanize::Plugin::$plugin"->init($self))
->options(@opts);
(Now the thought has just occurred to me that, if a plugin has '::'
in its name, we might want to allow a hyphen instead).
> What
> do the plugin class-methods do for state storage? They just throw
> keys
> into the $mech object?
They use the plugin object.
>
> It seems that you can have multiple plugins, but they overwrite
> callbacks as they're installed?
No, they get added to a list of callbacks for a particular hook (see
the push statement in add_handler). A callback can call
WWW::Mechanize::next_handler to signal Mech try the next one. Yes,
this does need documentation.
Attached are two patches. Mech-plugins-2-from-scratch.diff is a diff
between my working copy and Mech 1.30. Mech-plugins.diff is a diff
between the working copy and the last patch. Look at whichever of the
two is easier for you.
Father Chrysostomos
Mech-plugins-2-from-scratch.diff
(application/octet-stream, 11.8 KB)
diff -rup WWW-Mechanize-1.30/lib/WWW/Mechanize.pm WWW-Mechanize-1.30 copy 2/lib/WWW/Mechanize.pm
--- WWW-Mechanize-1.30/lib/WWW/Mechanize.pm 2007-05-24 19:32:10.000000000 -0700
+++ WWW-Mechanize-1.30 copy 2/lib/WWW/Mechanize.pm 2007-07-19 22:46:24.000000000 -0700
@@ -105,6 +105,7 @@ use HTTP::Request 1.30;
use LWP::UserAgent 2.003;
use HTML::Form 1.00;
use HTML::TokeParser;
+use Exporter 'import';
use base 'LWP::UserAgent';
@@ -113,6 +114,13 @@ BEGIN {
$HAS_ZLIB = eval 'use Compress::Zlib (); 1;';
}
+our @EXPORT_OK = qw/next_handler abort/;
+our @EXPORT_TAGS = (
+ callback => ['next_handler', 'abort'],
+ all => \@EXPORT_OK,
+);
+
+
=head1 CONSTRUCTOR AND STARTUP
=head2 new()
@@ -490,7 +498,11 @@ sub response { my $self = shift; re
sub status { my $self = shift; return $self->{status}; }
sub ct { my $self = shift; return $self->{ct}; }
sub base { my $self = shift; return $self->{base}; }
-sub current_form { my $self = shift; return $self->{form}; }
+sub current_form {
+ my $self = shift;
+ $self->_extract_forms() unless $self->{_extracted_forms};
+ return $self->{form} ||= $self->{forms}->[0];
+}
sub is_html { my $self = shift; return defined $self->{ct} && ($self->{ct} eq 'text/html'); }
=head2 $mech->title()
@@ -547,23 +559,30 @@ but will likely be backwards-compatible
sub content {
my $self = shift;
- my $content = $self->{content};
+ my $content;
if ( $self->is_html ) {
my %parms = @_;
if ( exists $parms{base_href} ) {
my $arg = (delete $parms{base_href}) || $self->base;
+ $content = $self->_call_handler('get_content') ||
+ $self->{content};
$content=~s/<head>/<head>\n<base href="$arg">/;
}
if ( my $arg = delete $parms{format} ) {
if ($arg eq 'text') {
- require HTML::TreeBuilder;
- my $tree = HTML::TreeBuilder->new();
- $tree->parse($content);
- $tree->eof();
- $tree->elementify(); # just for safety
- $content = $tree->as_text();
- $tree->delete;
+ unless(
+ $content = $self->_call_handler('get_text_content')
+ ) {
+ $content = $self->{content};
+ require HTML::TreeBuilder;
+ my $tree = HTML::TreeBuilder->new();
+ $tree->parse($content);
+ $tree->eof();
+ $tree->elementify(); # just for safety
+ $content = $tree->as_text();
+ $tree->delete;
+ }
}
else {
$self->die( qq{Unknown "format" parameter "$arg"} );
@@ -574,7 +593,8 @@ sub content {
}
} # is HTML
- return $content;
+ return $content || $self->_call_handler('get_content') ||
+ $self->{content};
}
=head1 LINK METHODS
@@ -1093,6 +1113,7 @@ context, returns an array reference of a
sub forms {
my $self = shift ;
+ $self->_extract_forms() unless $self->{_extracted_forms};
return @{$self->{forms}} if wantarray;
return $self->{forms};
}
@@ -1117,8 +1138,10 @@ sub form_number {
my ($self, $form) = @_;
# XXX Should we die if no $form is defined? Same question for form_name()
- if ($self->{forms}->[$form-1]) {
- $self->{form} = $self->{forms}->[$form-1];
+ my $forms = $self->forms;
+
+ if ($forms->[$form-1]) {
+ $self->{form} = $forms->[$form-1];
return $self->{form};
}
else {
@@ -1215,7 +1238,7 @@ sub field {
my ($self, $name, $value, $number) = @_;
$number ||= 1;
- my $form = $self->{form};
+ my $form = $self->current_form;
if ($number > 1) {
$form->find_input($name, undef, $number)->value($value);
}
@@ -1249,7 +1272,7 @@ undef and calls C<< $self>warn() >> with
sub select {
my ($self, $name, $value) = @_;
- my $form = $self->{form};
+ my $form = $self->current_form;
my $input = $form->find_input($name);
if (!$input) {
@@ -1492,7 +1515,7 @@ sub value {
my $name = shift;
my $number = shift || 1;
- my $form = $self->{form};
+ my $form = $self->current_form;
if ( $number > 1 ) {
return $form->find_input( $name, undef, $number )->value();
}
@@ -1518,7 +1541,7 @@ Returns an L<HTTP::Response> object.
sub click {
my ($self, $button, $x, $y) = @_;
for ($x, $y) { $_ = 1 unless defined; }
- my $request = $self->{form}->click($button, $x, $y);
+ my $request = $self->current_form->click($button, $x, $y);
return $self->request( $request );
}
@@ -1577,7 +1600,7 @@ sub click_button {
$_ = 1 unless defined;
}
- my $form = $self->{form};
+ my $form = $self->current_form;
my $request;
if ( $args{name} ) {
$request = $form->click( $args{name}, $args{x}, $args{y} );
@@ -1616,7 +1639,7 @@ longer so.
sub submit {
my $self = shift;
- my $request = $self->{form}->make_request;
+ my $request = $self->current_form->make_request;
return $self->request( $request );
}
@@ -1893,15 +1916,23 @@ Returns an L<HTTP::Response> object.
sub request {
my $self = shift;
- my $request = shift;
+ my $orig_request = shift;
- $request = $self->_modify_request( $request );
+ my $request = $self->_call_handler( 'modify_request', $orig_request );
+ defined $request
+ ? $request || ($request = $self->_modify_request( $orig_request ))
+ : return;
+
+ my $response = $self->_call_handler( 'make_request', $request );
+ defined $response
+ ? $response || ($response = $self->_make_request( $request ))
+ : return;
if ( $request->method eq 'GET' || $request->method eq 'POST' ) {
$self->_push_page_stack();
}
- $self->_update_page($request, $self->_make_request( $request, @_ ));
+ $self->_update_page($request, $response);
}
=head2 $mech->update_html( $html )
@@ -1949,15 +1980,9 @@ sub update_html {
$self->{ct} = 'text/html';
$self->{content} = $html;
- $self->{forms} = [ HTML::Form->parse($html, $self->base) ];
- for my $form (@{ $self->{forms} }) {
- for my $input ($form->inputs) {
- if ($input->type eq 'file') {
- $input->value( undef );
- }
- }
- }
- $self->{form} = $self->{forms}->[0];
+ $self->_call_handler('parse_html', $html);
+
+ $self->{_extracted_forms} = 0;
$self->{_extracted_links} = 0;
$self->{_extracted_images} = 0;
@@ -2161,6 +2186,7 @@ sub _reset_page {
$self->{_extracted_links} = 0;
$self->{_extracted_images} = 0;
+ $self->{_extracted_forms} = 0;
$self->{links} = [];
$self->{images} = [];
$self->{forms} = [];
@@ -2188,13 +2214,18 @@ sub _extract_links {
my $self = shift;
- $self->{links} = [];
- if ( defined $self->{content} ) {
- my $parser = HTML::TokeParser->new(\$self->{content});
- while ( my $token = $parser->get_tag( keys %link_tags ) ) {
- my $link = $self->_link_from_token( $token, $parser );
- push( @{$self->{links}}, $link ) if $link;
- } # while
+ if (my $ret = $self->_call_handler('extract_links')) {
+ $self->{links} = $ret;
+ }
+ else {
+ $self->{links} = [];
+ if ( defined $self->{content} ) {
+ my $parser = HTML::TokeParser->new(\$self->content);
+ while ( my $token = $parser->get_tag( keys %link_tags ) ) {
+ my $link = $self->_link_from_token( $token, $parser );
+ push( @{$self->{links}}, $link ) if $link;
+ } # while
+ }
}
$self->{_extracted_links} = 1;
@@ -2203,6 +2234,30 @@ sub _extract_links {
}
+sub _extract_forms { # XXX documentation?
+ my $self = shift;
+
+ if (my $ret = $self->_call_handler('extract_forms')) {
+ $self->{forms} = $ret;
+ }
+ else {
+ $self->{forms} =
+ [ HTML::Form->parse($self->content, $self->base) ];
+ for my $form (@{ $self->{forms} }) {
+ for my $input ($form->inputs) {
+ if ($input->type eq 'file') {
+ $input->value( undef );
+ }
+ }
+ }
+ }
+
+ $self->{_extracted_forms} = 1;
+
+ return;
+}
+
+
my %image_tags = (
img => 'src',
input => 'src',
@@ -2211,14 +2266,19 @@ my %image_tags = (
sub _extract_images {
my $self = shift;
- $self->{images} = [];
-
- if ( defined $self->{content} ) {
- my $parser = HTML::TokeParser->new(\$self->{content});
- while ( my $token = $parser->get_tag( keys %image_tags ) ) {
- my $image = $self->_image_from_token( $token, $parser );
- push( @{$self->{images}}, $image ) if $image;
- } # while
+ if (my $ret = $self->_call_handler('extract_images')) {
+ $self->{images} = $ret;
+ }
+ else {
+ $self->{images} = [];
+
+ if ( defined $self->{content} ) {
+ my $parser = HTML::TokeParser->new(\$self->content);
+ while ( my $token = $parser->get_tag( keys %image_tags ) ) {
+ my $image = $self->_image_from_token( $token, $parser );
+ push( @{$self->{images}}, $image ) if $image;
+ } # while
+ }
}
$self->{_extracted_images} = 1;
@@ -2406,6 +2466,89 @@ sub _die {
return &Carp::croak; ## no critic
}
+
+# XXX: Callback Mechanism -- This needs documentation.
+# The hooks are as follows:
+# parse_html
+# extract_forms -- should return an array ref
+# extract_links -- likewise
+# extract_images -- ditto
+# get_content
+# get_text_content
+# modify_request
+# make_request
+
+# If a callback routine returns false, it means that the default action
+# should be taken.
+
+sub add_handler {
+ my $self = shift;
+ my $name = shift;
+ my $sub = shift;
+
+ push @{$self->{callback}{$name}}, $sub;
+}
+
+# NOT an object method! This function is exported upon request.
+sub next_handler {
+ CORE::die \'next';
+}
+
+# NOT an object method! This function is exported upon request.
+# XXX Maybe the name should be something longer, like abort_action.
+# This only makes sense for modify_request and make_request.
+sub abort {
+ CORE::die \'abort';
+}
+
+# _call_handler returns undef when the handlers calls abort().
+# It returns a defined false if the handler returns false or undef.
+sub _call_handler {
+ my $self = shift;
+ my $name = shift;
+
+ if (exists $self->{callback}{$name}) {
+ local $@;
+ for (@{$self->{callback}{$name}}) {
+ my $ret = eval { $_->($self, @_); };
+ if (ref $@ eq 'SCALAR' && ${$@} eq 'next') {
+ next
+ }
+ elsif (ref $@ eq 'SCALAR' && ${$@} eq 'abort') {
+ return
+ }
+ elsif ($@) { $self->die($@) } # propagate the error
+ return $ret || 0;
+ }
+ }
+ return 0; # indicates that the default action should be taken
+}
+
+
+# XXX: Plugin Mechanism -- This needs documentation.
+
+# This calls init if the plugin in question has not been loaded for
+# this mech object. Otherwise, it calls options. The 'init' method will
+# return a plugin object (actually it doesn't have to), that will be stored
+# in the plugins hash.
+sub use_plugin {
+ my($self, $plugin, @opts) = @_;
+ my $plugins = $self->{plugins} ||= {};
+ $plugin =~ s/-/::/g;
+ if(exists $plugins->{$plugin}) {
+ $plugins->{$plugin}->options(@opts);
+ }
+ else {
+ require "WWW/Mechanize/Plugin/$plugin.pm";
+ ($plugins->{$plugin} =
+ "WWW::Mechanize::Plugin::$plugin"->init($self))
+ ->options(@opts);
+ }
+ $plugins->{$plugin};
+}
+sub plugin { my $self = shift; return $self->{plugins}{+shift}; }
+
+
1; # End of module
__END__
Mech-plugins-2.diff
(application/octet-stream, 4.2 KB)
diff -rup WWW-Mechanize-1.30 copy/lib/WWW/Mechanize.pm WWW-Mechanize-1.30 copy 2/lib/WWW/Mechanize.pm
--- WWW-Mechanize-1.30 copy/lib/WWW/Mechanize.pm 2007-07-15 23:35:44.000000000 -0700
+++ WWW-Mechanize-1.30 copy 2/lib/WWW/Mechanize.pm 2007-07-19 22:46:24.000000000 -0700
@@ -501,7 +501,7 @@ sub base { my $self = shift; re
sub current_form {
my $self = shift;
$self->_extract_forms() unless $self->{_extracted_forms};
- return $self->{form} = $self->{forms}->[0];
+ return $self->{form} ||= $self->{forms}->[0];
}
sub is_html { my $self = shift; return defined $self->{ct} && ($self->{ct} eq 'text/html'); }
@@ -1138,10 +1138,10 @@ sub form_number {
my ($self, $form) = @_;
# XXX Should we die if no $form is defined? Same question for form_name()
- $self->_extract_forms() unless $self->{_extracted_forms};
+ my $forms = $self->forms;
- if ($self->{forms}->[$form-1]) {
- $self->{form} = $self->{forms}->[$form-1];
+ if ($forms->[$form-1]) {
+ $self->{form} = $forms->[$form-1];
return $self->{form};
}
else {
@@ -1168,8 +1168,6 @@ Note that this functionality requires li
sub form_name {
my ($self, $form) = @_;
- $self->_extract_forms() unless $self->{_extracted_forms};
-
my $temp;
my @matches = grep {defined($temp = $_->attr('name')) and ($temp eq $form) } $self->forms;
if ( my $nmatches = @matches ) {
@@ -1202,8 +1200,6 @@ sub form_with_fields {
my ($self, @fields) = @_;
die 'no fields provided' unless scalar @fields;
- $self->_extract_forms() unless $self->{_extracted_forms};
-
my @matches;
FORMS: for my $form (@{ $self->forms }) {
my @fields_in_form = $form->param();
@@ -1242,8 +1238,7 @@ sub field {
my ($self, $name, $value, $number) = @_;
$number ||= 1;
- $self->_extract_forms() unless $self->{_extracted_forms};
- my $form = $self->{form};
+ my $form = $self->current_form;
if ($number > 1) {
$form->find_input($name, undef, $number)->value($value);
}
@@ -1277,8 +1272,7 @@ undef and calls C<< $self>warn() >> with
sub select {
my ($self, $name, $value) = @_;
- $self->_extract_forms() unless $self->{_extracted_forms};
- my $form = $self->{form};
+ my $form = $self->current_form;
my $input = $form->find_input($name);
if (!$input) {
@@ -1521,8 +1515,7 @@ sub value {
my $name = shift;
my $number = shift || 1;
- $self->_extract_forms() unless $self->{_extracted_forms};
- my $form = $self->{form};
+ my $form = $self->current_form;
if ( $number > 1 ) {
return $form->find_input( $name, undef, $number )->value();
}
@@ -1548,8 +1541,7 @@ Returns an L<HTTP::Response> object.
sub click {
my ($self, $button, $x, $y) = @_;
for ($x, $y) { $_ = 1 unless defined; }
- $self->_extract_forms() unless $self->{_extracted_forms};
- my $request = $self->{form}->click($button, $x, $y);
+ my $request = $self->current_form->click($button, $x, $y);
return $self->request( $request );
}
@@ -1608,8 +1600,7 @@ sub click_button {
$_ = 1 unless defined;
}
- $self->_extract_forms() unless $self->{_extracted_forms};
- my $form = $self->{form};
+ my $form = $self->current_form;
my $request;
if ( $args{name} ) {
$request = $form->click( $args{name}, $args{x}, $args{y} );
@@ -1648,8 +1639,7 @@ longer so.
sub submit {
my $self = shift;
- $self->_extract_forms() unless $self->{_extracted_forms};
- my $request = $self->{form}->make_request;
+ my $request = $self->current_form->make_request;
return $self->request( $request );
}
@@ -2544,13 +2534,15 @@ sub _call_handler {
sub use_plugin {
my($self, $plugin, @opts) = @_;
my $plugins = $self->{plugins} ||= {};
+ $plugin =~ s/-/::/g;
if(exists $plugins->{$plugin}) {
$plugins->{$plugin}->options(@opts);
}
else {
require "WWW/Mechanize/Plugin/$plugin.pm";
- $plugins->{$plugin} =
- "WWW::Mechanize::Plugin::$plugin"->init($self,@opts);
+ ($plugins->{$plugin} =
+ "WWW::Mechanize::Plugin::$plugin"->init($self))
+ ->options(@opts);
}
$plugins->{$plugin};
}
WWW-Mechanize-Plugin-JavaScript-0.0.2.tar.gz
(application/x-gzip, 5.4 KB) - not displayed