view release on metacpan or  search on metacpan

lib/XML/Loy.pm  view on Meta::CPAN

#     # usage:
#     sub author {
#       return $autor or $self->try_further;
#     };
#
#  - ALERT!
#      Do not allow for namespace islands
#      Search $obj->find('* *[xmlns]') and change prefixing
#      After ->SUPER::new;
#      Or:
#      Do allow for namespace islands and check for the
#      namespace to add instead of the package name before
#      prefixing.
#
# - set() should really try to overwrite.
#
# - add() with -before => '' and -after => ''
#   - maybe possible to save to element
#   - Maybe with small changes a change to the object
#     (encoding, xml etc.) can be done
#
# - closest() (jQuery)

our @CARP_NOT;

# Import routine, run when calling the class properly
sub import {
  my $class = shift;

  return unless my $flag = shift;

  return unless $flag =~ /^-?(?i:base|with)$/;

  # Allow for manipulating the symbol table
  no strict 'refs';
  no warnings 'once';

  # The caller is the calling (inheriting) class
  my $caller = caller;
  push @{"${caller}::ISA"}, __PACKAGE__;

  if (@_) {

    # Get class variables
    my %param = @_;

    # Set class variables
    foreach (qw/namespace prefix mime/) {
      if (exists $param{$_}) {
        ${ "${caller}::" . uc $_ } = delete $param{$_};
      };
    };

    # Set class hook
    if (exists $param{on_init}) {
      *{"${caller}::ON_INIT"} = delete $param{on_init};
    };
  };

  # Make inheriting classes strict and modern
  strict->import;
  warnings->import;
  utf8->import;
  feature->import(':5.10');
};


# Return class variables
{
  no strict 'refs';
  sub _namespace { ${"${_[0]}::NAMESPACE"}   || '' };
  sub _prefix    { ${"${_[0]}::PREFIX"}      || '' };
  sub mime       {
    ${ (blessed $_[0] || $_[0]) . '::MIME'}  || 'application/xml'
  };
  sub _on_init   {
    my $class = shift;
    my $self = $class;

    # Run object method
    if (blessed $class) {
      $class = blessed $class;
    }

    # Run class method
    else {
      $self = shift;
    };

    # Run init hook
    if ($class->can('ON_INIT')) {
      *{"${class}::ON_INIT"}->($self) ;
    };
  };
};


# Construct new XML::Loy object
sub new {
  my $class = shift;

  my $self;

  # Create from parent class
  # Empty constructor
  unless ($_[0]) {
    $self = $class->SUPER::new->xml(1);
  }

  # XML::Loy object
  elsif (ref $_[0]) {
    $self = $class->SUPER::new(@_)->xml(1);
  }

  # XML string
  elsif (index($_[0],'<') >= 0 || index($_[0],' ') >= 0) {
    $self = $class->SUPER::new->xml(1)->parse(@_);
  }

  # Create a new node
  else {