view release on metacpan or  search on metacpan

lib/Email/MIME/XPath.pm  view on Meta::CPAN

      -internal      => { -prefix => '__xpath_' },
      -special,
    ],
  },
};
 
sub _build_external {
  my ($class, $group, $arg) = @_;
  return {
    map {
      my $method = $_;
      $method => sub {
        my $self = shift;
        $self->__build_parents;
        return $self->__xpath_engine->$method(@_, $self);
      }
    } @EXTERNAL_AUTO
  };
}

sub matches {
  my $self = shift;
  $self->__build_parents;
  my ($path, $context) = @_;
  $context ||= $self;
  return $self->__xpath_engine->matches($self, $path, $context);
};

sub findnode {
  my $self = shift;
  $self->__build_parents;
  my (@nodes) = $self->__xpath_engine->findnodes(@_, $self);
  Carp::croak "findnode found more than one node" if @nodes > 1;
  return $nodes[0];
}

sub __xpath_engine_options { () }

sub __xpath_engine {
  return $_[0]->{__xpath_engine} ||= Tree::XPathEngine->new(
    $_[0]->__xpath_engine_options
  );
}

# this is a terrible, terrible hack.  something like this should be in
# Email::MIME instead.  try to future-proof it somewhat.  -- hdp, 2007-04-20
sub __is_multipart {
  return grep { $_ != $_[0] } $_[0]->parts;
}

# XXX a lot of trickery here is necessary because Email::MIME objects can be
# shared among multiple trees at once.  We keep track of parent/address
# information inside the XPathEngine object, which is (originally) only inside
# the top-level part.
sub __build_parents {
  my $self = shift;
  return if $self->__xpath_engine->{__parent};
  my $parent  = $self->__xpath_engine->{__parent}  = {};
  my $address = $self->__xpath_engine->{__address} = {};
  $self->__xpath_engine->{__root} = $self;
  Scalar::Util::weaken($self->__xpath_engine->{__root});
  my $id = 0;
  $address->{$self} = sprintf("%03d", $id++);
  if (__is_multipart($self)) {
    my @q = $self;
    while (@q) { 
      my $part = shift @q;
      my @subparts = $part->parts;
      for (@subparts) {
        $parent->{$_} = $part;
        Scalar::Util::weaken $parent->{$_};
        $address->{$_} = sprintf("%03d", $id++);
        # XXX this will cause collisions if more than one Email::MIME::XPath
        # shares parts
        $_->{__xpath_engine} = $self->__xpath_engine;
        Scalar::Util::weaken $_->{__xpath_engine};
      }
      push @q, grep { __is_multipart($_) } @subparts;
    }
  }
}

sub __xpath_parent {
  $_[0]->__xpath_engine->{__parent}->{$_[0]}
}

sub address {
  $_[0]->__xpath_engine->{__address}->{$_[0]}
}

sub get_name {
  #my $subname = (caller(0))[3]; warn "$subname from " . $_[0]->__xpath_address;
  my $name =  (split /;/, $_[0]->content_type || 'text/plain')[0];
  $name =~ tr{/+}{._};
  $name = (split /\./, $name)[1];
  #my $name = __is_multipart($_[0]) ? 'multi' : 'part';
  #warn "name = $name";
  return $name;
}
sub get_next_sibling {
  #my $subname = (caller(0))[3]; warn "$subname from " . $_[0]->__xpath_address;
  return;
}
sub get_previous_sibling {
  #my $subname = (caller(0))[3]; warn "$subname from " . $_[0]->__xpath_address;
  return;
}
sub get_root_node {
  #my $subname = (caller(0))[3]; warn "$subname from " . $_[0]->__xpath_address;
  $_[0]->__xpath_engine->{__root}->__xpath_get_parent_node;
}
sub get_parent_node { 
  #my $subname = (caller(0))[3]; warn "$subname from " . $_[0]->__xpath_address;
  my $node = shift;
  return $node->__xpath_parent || bless { root => $node }, 'Email::MIME::XPath::Root';
}
sub get_child_nodes {
  #my $subname = (caller(0))[3]; warn "$subname from " . $_[0]->__xpath_address;
  my @kids = grep { $_ != $_[0] } $_[0]->parts;
  return @kids;
}
sub is_element_node { 1 }
sub is_document_node { 0 }
sub is_attribute_node { 0 }
sub is_text_node { }

sub get_attributes { 
  #my $subname = (caller(0))[3]; warn "$subname from " . $_[0]->__xpath_address;
  my $node = shift;
  my %attr = (
    content_type => (split /;/, $node->content_type || 'text/plain')[0],
    address      => $node->__xpath_address,
    $node->header('Content-Disposition') ? (filename => $node->filename) : (),
    map {
      my $val = $node->header($_);
      defined $val ? (lc($_) => $val) : ()