Fwd: Mech JS support

Father Chrysostomos <[email protected]>
Newsgroups gmane.comp.lang.perl.modules.lwp
Message-ID <[email protected]> 
On Jul 17, 2007, at 9:55 PM, Andy Lester wrote:

>
> On Jul 17, 2007, at 11:53 PM, Father Chrysostomos wrote:
>
>> What do you think? (And is the name intuitive enough?) Or do you  
>> think that a plugin mechanism for Mech would be good anyway?
>
> Send it to the LWP list and see what people think.  I'm only one  
> pair of eyes.
>

A while back, I suggested to Andy a plugin mechanism for  
WWW::Mechanize that would allow me to write a JavaScript plugin for  
it. Here is what I sent him yesterday, for everyone’s perusal.

I must add that the Mech patch does not take into account what should  
happen to plugin objects when _push_pagestack is called. I suggest  
that use_plugin record its arguments, so that the plugin objects can  
be created afresh each time a new page is loaded.

Also, please CC to me (sprout [at sign] cpan . org) any important  
replies, so I don't have to subscribe to the mailing list. Thank you.

>
> Hello,
>
> Please have a look at the attached patch for Mech and tell me what  
> you think. I have not tested it thoroughly yet. If you like, I can  
> write tests and documentation as well.
>
> Attached also are pre-alpha versions of the plugins, in case you  
> would like to look at them. So far, only scripts embedded in the  
> page that use document.write() to generate HTML code really work. I  
> still have to get <script src=...> to work and I have to trigger  
> event handlers when appropriate. But, just to demonstrate, look at  
> this four-liner, which fetches a page that has generated content:
>
> use WWW::Mechanize;
> ($m = new WWW::Mechanize quiet => 1)->use_plugin(JavaScript);
> $m->get('http://ctosonline.org/order/'); # contains a JS-scrambled  
> e-mail address
> print $m->content(format => text), "\n";
>
> (I do still have to resolve the "Attempt to free unreferenced  
> scalar" issue that show up in perl 5.8.8.)
>
>
> On second thought, seeing that wmpdom is going to override most of  
> Mech's content-handling functionality anyway, maybe I could simply  
> make a subclass of Mech, called WWW::Mechanize::Scriptable, that  
> will provide the DOM tree and allow various scripting engines to  
> plug in to it. And this would make it easier for you, too. What do  
> you think? (And is the name intuitive enough?) Or do you think that  
> a plugin mechanism for Mech would be good anyway?
>
>
> Father Chrysostomos
>
Mech-plugins.diff (application/octet-stream, 12.3 KB) 
diff -rup WWW-Mechanize-1.30/lib/WWW/Mechanize.pm WWW-Mechanize-1.30 copy/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/lib/WWW/Mechanize.pm	2007-07-15 23:35:44.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,6 +1138,8 @@ 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};
+
     if ($self->{forms}->[$form-1]) {
         $self->{form} = $self->{forms}->[$form-1];
         return $self->{form};
@@ -1145,6 +1168,8 @@ 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 ) {
@@ -1177,6 +1202,8 @@ 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();
@@ -1215,6 +1242,7 @@ sub field {
     my ($self, $name, $value, $number) = @_;
     $number ||= 1;
 
+    $self->_extract_forms() unless $self->{_extracted_forms};
     my $form = $self->{form};
     if ($number > 1) {
         $form->find_input($name, undef, $number)->value($value);
@@ -1249,6 +1277,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 $input = $form->find_input($name);
@@ -1492,6 +1521,7 @@ sub value {
     my $name = shift;
     my $number = shift || 1;
 
+    $self->_extract_forms() unless $self->{_extracted_forms};
     my $form = $self->{form};
     if ( $number > 1 ) {
         return $form->find_input( $name, undef, $number )->value();
@@ -1518,6 +1548,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);
     return $self->request( $request );
 }
@@ -1577,6 +1608,7 @@ sub click_button {
         $_ = 1 unless defined;
     }
 
+    $self->_extract_forms() unless $self->{_extracted_forms};
     my $form = $self->{form};
     my $request;
     if ( $args{name} ) {
@@ -1616,6 +1648,7 @@ longer so.
 sub submit {
     my $self = shift;
 
+    $self->_extract_forms() unless $self->{_extracted_forms};
     my $request = $self->{form}->make_request;
     return $self->request( $request );
 }
@@ -1893,15 +1926,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 +1990,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 +2196,7 @@ sub _reset_page {
 
     $self->{_extracted_links} = 0;
     $self->{_extracted_images} = 0;
+    $self->{_extracted_forms} = 0;
     $self->{links} = [];
     $self->{images} = [];
     $self->{forms} = [];
@@ -2188,13 +2224,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 +2244,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 +2276,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 +2476,87 @@ 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} ||= {};
+    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};
+}
+sub plugin { my $self = shift; return $self->{plugins}{+shift}; }
+
+
 1; # End of module
 
 __END__
WWW-Mechanize-Plugin-JavaScript-0.0.1.tar.gz (application/x-gzip, 5.4 KB) - not displayed
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.