view release on metacpan or  search on metacpan

lib/App/RSS2Leafnode.pm  view on Meta::CPAN

  }
  return 1;
}

#------------------------------------------------------------------------------
# ImageMagick bits

# $type is "gif", "ico" etc, $data is an image in a byte string
# return a byte string of png, or undef if $data unrecognised
sub imagemagick_to_png {
  my ($self, $type, $data) = @_;
  ### $type
  my $image = $self->imagemagick_from_data($type,$data) // return;

  my $width = $image->Get('width');
  my $height = $image->Get('height');
  ### compress: $image->Get('compression')
  $self->verbose (2, "   image ${width}x${height}");
  if ($width == 0 || $height == 0) {
    return;
  }
  if ($width <= 48 && $height <= 48 && $type eq 'png') {
    return $data;
  }

  # having downloaded the image is it better to keep a banner but shrink it,
  # or discard as no good?
  #
  # $self->face_wh_ok ($width, $height) || return;

  if ($width > 48 || $height > 48) {
    my $factor;
    if ($width <= 2*48 && $height <= 2*48) {
      $factor = 0.5;
    } else {
      $factor = min (48 / $width, 48 / $height);
    }
    $width = POSIX::ceil ($width * $factor);
    $height = POSIX::ceil ($height * $factor);
    $self->verbose (2, "  image shrink by $factor to ${width}x${height}");
    # cf LiquidResize() or plain Resize()
    $image->AdaptiveResize (width => $width, height => $height);
  }

  my $ret = $image->Set (magick => 'PNG8');
  ### ret: "$ret"
  ### ret: $ret+0
  if ($ret != 0) {
    print "oops, imagemagick doesn't like PNG8: $ret\n";
    return;
  }
  ### compress: $image->Get('compression')

  # $image->Write ('/tmp/x.png');
  ($data) = $image->ImageToBlob ();
  return $data;
}


# $type is "png", "ico" etc, $data is an image in a byte string
# return a Image::Magick object, or undef if Perl-Magick not available
sub imagemagick_from_data {
  my ($self, $type, $data) = @_;
  ### imagemagick_from_data(): $type
  eval { require Image::Magick } or return;

  my $image = Image::Magick->new (magick=>$type);
  # $image->Set(debug=>'All');
  my $ret = $image->BlobToImage ($data);
  ### ret: "$ret"
  ### ret: $ret+0
  if ($ret == 1) {
    return $image;
  }

  # try again without the $type forced, in case bad Content-Type from http
  $image = Image::Magick->new;
  # $image->Set(debug=>'All');
  $ret = $image->BlobToImage ($data);
  ### ret: "$ret"
  ### ret: $ret+0
  if ($ret == 1) {
    return $image;
  }

  print __x("  imagemagick doesn't like image data ({length} bytes) from {url}: {error}\n",
            length => length($data),
            url    => $self->{'download_face_uncached'},
            error  => $ret);
  return undef;
}


#------------------------------------------------------------------------------
# XML::Liberal

use constant::defer have_xml_liberal => sub {
  my ($self) = @_;
  if (eval { require XML::Liberal; 1 }) {
    return 1;
  }
  $self->verbose (3, __x('XML::Liberal not available: {error}', error => $@));
  return 0;
};

# try to correct $xmlstr
# if successful return a new xml string, otherwise return undef
sub xml_liberal_correction {
  my ($self, $xmlstr) = @_;
  $self->have_xml_liberal or return;

  ### try XML-Liberal ...
  my $liberal = XML::Liberal->new('LibXML');
  if (my $doc = eval { $liberal->parse_string($xmlstr) }) {
    return $doc->toString;
  } else {
    $self->verbose (2, __x('XML::Liberal parse error: {error}', error => $@));
    return undef;
  }
}


#------------------------------------------------------------------------------
# error as news message

sub error_message {
  my ($self, $subject, $message, $attach_bytes) = @_;

  require Encode;
  my $charset = 'utf-8';
  $message = str_ensure_newline ($message);
  $message = Encode::encode ($charset, $message, Encode::FB_DEFAULT());

  my $date = rfc822_time_now();
  require Digest::MD5;
  my $msgid = $self->url_to_msgid
    ('http://localhost',