This is an automated email from the git hooks/post-receive script. jame-guest pushed a commit to tag v0.08 in repository libweasel-perl.
commit b267d9eb8bee65753600ae2871845658b3886d3a Author: Erik Huelsmann <[email protected]> Date: Fri Aug 26 18:59:06 2016 +0200 * Add logging --- lib/Weasel/Session.pm | 161 ++++++++++++++++++++++++++++++++++++++++++-------- t/01-logging.t | 78 ++++++++++++++++++++++++ 2 files changed, 215 insertions(+), 24 deletions(-) diff --git a/lib/Weasel/Session.pm b/lib/Weasel/Session.pm index 83e6b8e..ad0a941 100644 --- a/lib/Weasel/Session.pm +++ b/lib/Weasel/Session.pm @@ -42,6 +42,7 @@ use Module::Runtime qw/ use_module /;; use Weasel::FindExpanders qw/ expand_finder_pattern /; use Weasel::WidgetHandlers qw| best_match_handler_class |; + =head1 ATTRIBUTES =over @@ -102,6 +103,17 @@ sub _page_builder { return $class->new(session => $self); } +=item log_hook + +Upon instantiation can be set to log consumer; a function of 3 arguments: + 1. the name of the event + 2. the text to be logged (or a coderef to be called without arguments returning such) + +=cut + +has 'log_hook' => (is => 'ro', + isa => 'Maybe[CodeRef]'); + =item page_class Upon instantiation can be set to an alternative class name for the C<page> @@ -139,6 +151,7 @@ has 'poll_delay' => (is => 'rw', =back + =head1 METHODS @@ -154,7 +167,8 @@ textarea elements and input elements of type text and password. sub clear { my ($self, $element) = @_; - $self->driver->clear($element->_id); + $self->_logged(sub { $self->driver->clear($element->_id); }, + 'clear', 'clearing input element'); } =item click([$element]) @@ -168,7 +182,11 @@ current mouse location. sub click { my ($self, $element) = @_; - $self->driver->click(($element) ? $element->_id : undef); + $self->_logged( + sub { + $self->driver->click(($element) ? $element->_id : undef); + }, + 'click', ($element) ? 'clicking element' : 'clicking window'); } =item find($element, $locator [, scheme => $scheme] [, %locator_args]) @@ -183,11 +201,14 @@ sub find { my ($self, @args) = @_; my $rv; - $self->wait_for( + $self->_logged( sub { - my @rv = @{$self->find_all(@args)}; - return $rv = shift @rv; - }); + $self->wait_for( + sub { + my @rv = @{$self->find_all(@args)}; + return $rv = shift @rv; + }); + }, 'find', 'find ' . $args[1]); return $rv; } @@ -206,13 +227,25 @@ sub find_all { my ($self, $element, $pattern, %args) = @_; my $expanded_pattern = expand_finder_pattern($pattern, \%args); - my @rv = - map { $self->_wrap_widget($_) } - $self->driver->find_all($element->_id, - $expanded_pattern, - $args{scheme}); - print STDERR "found " . scalar(@rv) . " elements for $pattern " . (join(', ', %args)) . "\n"; - print STDERR ' - ' . ref($_) . " (" . $_->tag_name . ")\n" for (@rv); + my @rv = $self->_logged( + sub { + return + map { $self->_wrap_widget($_) } + $self->driver->find_all($element->_id, + $expanded_pattern, + $args{scheme}); + }, + 'find_all', + sub { + my ($rv) = @_; + return "found " . scalar(@$rv) . " elements for $pattern " + . (join(', ', %args)) . "\n" + . (join("\n", + map { ' - ' . ref($_) + . ' (' . $_->tag_name . ")" } @$rv)); + }, + "pattern: $pattern"); + return wantarray ? @rv : \@rv; } @@ -230,7 +263,10 @@ sub get { $url = $self->base_url . $url; ###TODO add logging warning of urls without protocol part # which might indicate empty 'base_url' where one is assumed to be set - $self->driver->get($url); + $self->_logged( + sub { + return $self->driver->get($url); + }, 'get', "loading URL: $url"); } =item get_attribute($element, $attribute) @@ -243,7 +279,10 @@ identified by C<$element>, or C<undef> if the attribute isn't defined. sub get_attribute { my ($self, $element, $attribute) = @_; - return $self->driver->get_attribute($element->_id, $attribute); + return $self->_logged( + sub { + return $self->driver->get_attribute($element->_id, $attribute); + }, 'get_attribute', "element attribute '$attribute'"); } =item get_text($element) @@ -255,7 +294,11 @@ Returns the 'innerHTML' of the element identified by C<$element>. sub get_text { my ($self, $element) = @_; - return $self->driver->get_text($element->_id); + return $self->_logged( + sub { + return $self->driver->get_text($element->_id); + }, + 'get_text', 'element text'); } =item is_displayed($element) @@ -269,7 +312,11 @@ the viewport for interaction. sub is_displayed { my ($self, $element) = @_; - return $self->driver->is_displayed($element->_id); + return $self->_logged( + sub { + return $self->driver->is_displayed($element->_id); + }, + 'is_displayed', 'query is_displayed'); } =item screenshot($fh) @@ -285,7 +332,10 @@ Note: this version assumes pictures of type PNG will be written; sub screenshot { my ($self, $fh) = @_; - $self->driver->screenshot($fh); + $self->_logged( + sub { + $self->driver->screenshot($fh); + }, 'screenshot', 'screenshot'); } =item send_keys($element, @keys) @@ -298,7 +348,11 @@ simulating keyboard input. sub send_keys { my ($self, $element, @keys) = @_; - $self->driver->send_keys($element->_id, @keys); + $self->_logged( + sub { + $self->driver->send_keys($element->_id, @keys); + }, + 'send_keys', 'sending keys: ' . join('', @keys)); } =item tag_name($element) @@ -310,7 +364,10 @@ Returns the tag name of the element identified by C<$element>. sub tag_name { my ($self, $element) = @_; - return $self->driver->tag_name($element->_id); + return $self->_logged(sub { return $self->driver->tag_name($element->_id) }, + 'tag_name', + sub { my $tag = shift; return "found tag with name $tag" }, + 'getting tag name'); } =item wait_for($callback, [ retry_timeout => $number,] [poll_delay => $number]) @@ -326,11 +383,67 @@ session-global settings. sub wait_for { my ($self, $callback, %args) = @_; - $self->driver->wait_for($callback, - retry_timeout => $self->retry_timeout, - poll_delay => $self->poll_delay, - %args); + $self->_logged( + sub { + $self->driver->wait_for($callback, + retry_timeout => $self->retry_timeout, + poll_delay => $self->poll_delay, + %args); + }, + 'wait_for', 'waiting for condition'); +} + + +sub _appending_wrap { + my ($str) = @_; + return sub { + my $rv = shift; + if ($rv) { + return "$str ($rv)"; + } + else { + return $str; + } + } } +=item _logged($wrapped_fn, $event, $log_item, $log_item_pre) + +Invokes C<log_hook> when it's defined, before and after calling C<$wrapped_fn> +with no arguments, with the 'pre_' and 'post_' prefixes to the event name. + +C<$log_item> can be a fixed string or a function of one argument returning +the string to be logged. The argument passed into the function is the value +returned by the C<$wrapped_fn>. + +In case there is no C<$log_item_pre> to be called on the 'pre_' event, C<$log_item> +will be used instead, with no arguments. + +For performance reasons, the C<$log_item> and C<$log_item_pre> - when coderefs - aren't +called; instead they are passed as-is to the C<$log_hook> for lazy evaluation. + +=cut + +sub _logged { + my ($self, $f, $e, $l, $lp) = @_; + my $hook = $self->log_hook; + + return $f->() if ! defined $hook; + + $lp //= $l; + my $pre = (ref $lp eq 'CODE') ? $lp : _appending_wrap($lp); + my $post = (ref $l eq 'CODE') ? $l : _appending_wrap($l); + $hook->("pre_$e", $pre); + if (wantarray) { + my @rv = $f->(); + $hook->("post_$e", sub { return $l->(\@rv); }); + return @rv; + } + else { + my $rv = $f->(); + $hook->("post_$e", sub { return $l->($rv); }); + return $rv; + } +}; =item _wrap_widget($_id) diff --git a/t/01-logging.t b/t/01-logging.t new file mode 100644 index 0000000..061e524 --- /dev/null +++ b/t/01-logging.t @@ -0,0 +1,78 @@ +#!perl + + +use Data::Dumper; +use Test::More; + +package DummyDriver { + use Data::Dumper; + use Moose; + with 'Weasel::DriverRole'; + + sub tag_name { + my ($self, $tag) = @_; + + return $tag->{tag}; + } + + sub find_all { + my @rv = ( + { tag => 'span' }, + { tag => 'span' }, + ); + + return (wantarray) ? @rv : \@rv; + } +} + +use Weasel; +use Weasel::Session; + +my @logs; + +my $weasel = + Weasel->new( + default_session => 'default', + sessions => { + default => Weasel::Session->new( + driver => DummyDriver->new(), + log_hook => sub { + my ($event, $item) = @_; + $item = $item->() if ref $item eq 'CODE'; + push @logs, [ $event, $item ]; + }, + ), + }, + ); + +my $session = $weasel->session; + +# Specifically test `find_all' due to the complex nature: +# It can return an array ref in scalar context or an array in +# list context -- yet the logger will receive an array ref (always) +my @found = $session->page->find_all('span'); +my $found = $session->page->find_all('span'); + +is(scalar(@found), 2, 'Number of tags found equals two'); +is(ref $found, 'ARRAY', 'Scalar context returns ARRAYREF'); + +is_deeply(\@logs, + [['pre_find_all', 'pattern: span'], + ['pre_tag_name', 'getting tag name'], + ['post_tag_name', 'found tag with name span'], + ['pre_tag_name', 'getting tag name'], + ['post_tag_name', 'found tag with name span'], + ['post_find_all', 'found 2 elements for span + - Weasel::Element (span) + - Weasel::Element (span)'], + ['pre_find_all', 'pattern: span'], + ['pre_tag_name', 'getting tag name'], + ['post_tag_name', 'found tag with name span'], + ['pre_tag_name', 'getting tag name'], + ['post_tag_name', 'found tag with name span'], + ['post_find_all', 'found 2 elements for span + - Weasel::Element (span) + - Weasel::Element (span)'] + ], 'Compare log output'); + +done_testing; -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libweasel-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
