File Coverage

blib/lib/App/RSS2Leafnode/XML/Twig/Other.pm

Criterion	Covered	Total	%
statement	12	36	33.3
branch	0	8	0.0
condition	0	3	0.0
subroutine	4	8	50.0
pod	0	4	0.0
total	16	59	27.1

# Copyright 2007, 2008, 2009, 2010, 2011, 2012, 2013 Kevin Ryde
#
# This file is part of RSS2Leafnode.
#
# RSS2Leafnode is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# RSS2Leafnode is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with RSS2Leafnode.  If not, see .

package App::RSS2Leafnode::XML::Twig::Other;
use 5.004;
use strict;
use Exporter;
use vars '$VERSION', '@ISA', '@EXPORT_OK';

$VERSION = 77;
@ISA = ('Exporter');
@EXPORT_OK = (qw(elt_is_empty
                 elt_tree_strip_prefix
               ));

# XML::Twig

sub elt_is_empty {
  my ($elt) = @_;
  return ($elt->has_no_atts
          && ! $elt->has_child
          && $elt->text_only =~ /^\s*$/);
}

sub elt_tree_strip_prefix {
  my ($elt, $prefix) = @_;
  foreach my $child ($elt->descendants_or_self(qr/^\Q$prefix\E:/)) {
    $child->set_tag ($child->local_name);
  }
}

# Return a URI object for string $url.
# If $url is relative then it's resolved against xml:base, if available, to
# make it absolute.
# If $url is undef then return undef, which is handy if passing a possibly
# attribute like $elt->att('href').
# The feed toplevel has an xml:base set to the feed location if no other
# value, so elt_xml_based_uri() ends up relative to the feed location if no
# other xml:base.
#
sub elt_xml_based_uri {
  my ($elt, $url_str) = @_;
  if (! defined $url_str) { return undef; }
  require URI;
  my $uri = URI->new ($url_str);
  if (my $base = elt_xml_base ($elt)) {
    return $uri->abs ($base);
  } else {
    return $uri;
  }
}

# Return a URI object for the xml:base applying to $elt, or undef.
sub elt_xml_base {
  my ($elt) = @_;
  my @relative;
  for ( ; $elt; $elt = $elt->parent) {
    next if ! defined (my $base = $elt->att('xml:base'));
    $base = URI->new($base);
    if (defined $base->scheme) {
      # an absolute URL
      while (@relative) {
        $base = (pop @relative)->abs($base);
      }
      return $base;
    } else {
      # a relative path
      push @relative, $base;
    }
  }
  # oops, no base, only relative paths
  return undef;
}


1;
__END__