From 2ddd3376b2ca76946eab0af0d04e18adefe6d31c Mon Sep 17 00:00:00 2001 From: David Phillips Date: Sun, 22 Mar 2020 11:43:56 +1300 Subject: URL_Title: Add option to dump page content to log --- Plugin/URL_Title.pm | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/Plugin/URL_Title.pm b/Plugin/URL_Title.pm index d787d90..df72f02 100644 --- a/Plugin/URL_Title.pm +++ b/Plugin/URL_Title.pm @@ -8,6 +8,10 @@ use HTML::Entities; use utf8; use Encode; +# For optional debug page dumping +use IO::Compress::Gzip qw/gzip/; +use MIME::Base64 qw/encode_base64/; + use IdaliusConfig qw/assert_scalar/; my $config; @@ -21,6 +25,9 @@ sub configure { IdaliusConfig::assert_scalar($config, $self, "url_len"); die "url_len must be positive" if $config->{url_len} <= 0; + # debug_dump is an optional parameter to dump base64(gzip(page_data)) into + # the log - defaults to disabled and not checked here + $cmdref->($self, "title of", sub { $self->get_title_cmd(@_); }); return $self; @@ -54,7 +61,7 @@ sub start_handler sub get_title { - my ($what) = @_; + my ($logger, $what) = @_; my $url; # Drawn from RFC 3986ยง2 @@ -88,6 +95,16 @@ sub get_title my $html = $response->{content}; + if ($config->{debug_dump}) { + my $zipped; + if (gzip \$html => \$zipped) { + my $encoded = encode_base64($zipped, ""); + $logger->("debug_dump for $url: $encoded"); + } else { + $logger->("debug_dump gzip error: $!"); + } + } + $charset = undef; $content_type = undef; $title = undef; @@ -143,7 +160,7 @@ sub get_title_cmd { my ($self, $irc, $logger, $who, $where, $ided, $rest, $no_reenter, @arguments) = @_; - my ($title, $warning, $error) = get_title($rest); + my ($title, $warning, $error) = get_title($logger, $rest); $logger->($error) if $error; return $error if $error; @@ -157,7 +174,7 @@ sub on_message { my ($self, $logger, $who, $where, $raw_what, $what, $irc) = @_; - my ($title, $warning, $error) = get_title($what); + my ($title, $warning, $error) = get_title($logger, $what); # Log only errors, not warnings $logger->($error) if $error; -- cgit v1.1