view release on metacpan or  search on metacpan

lib/Rose/HTML/Object.pm  view on Meta::CPAN

# We "can" do what will eventually be AUTOLOADed HTML attribute methods
sub can
{
  my($self, $name) = @_;

  my $class = ref($self) || $self;

  my $code = $self->SUPER::can($name);
  return $code  if($code);

  return  unless($self->html_attr_is_valid($name) && $class->autoload_html_attr_methods);

  # can() expects a code ref that will actually work...
  return sub
  {
    my $self = $_[0];

    my $code = $self->SUPER::can($name); # exists already?
    goto &$code  if($code);

    $AUTOLOAD = $class;
    goto &AUTOLOAD
  };
}

sub __method_was_autoloaded
{
  my($class) = ref($_[0]) || $_[0];
  no strict 'refs';
  exists ${$class . '::__AUTOLOADED'}{$_[1]};
}

sub create_html_attr_methods
{
  my($class) = shift;

  my $count = 0;

  foreach my $attr (@_ ? @_ : $class->valid_html_attrs)
  {
    no strict 'refs';
    my $method = $class . '::' . $attr;
    next  if(defined &$method);
    *$method = sub { shift->html_attr($attr, @_) };
    $count++;
  }

  return $count;
}

sub import
{
  my($class) = shift;

  foreach my $arg (@_)
  {
    if($arg eq ':customize')
    {
      $class->import_methods(
        { target_class => (caller)[0] },
        qw(object_type_class_exists object_type_class_keys 
           delete_object_type_class object_type_classes 
           clear_object_type_classes object_type_class 
           inherit_object_type_classes object_type_classes_cache 
           inherit_object_type_class add_object_type_classes 
           delete_object_type_classes add_object_type_class
           localizer locale default_localizer default_locale));
    }
    else
    {
      carp "$class: Unknown import argument '$arg'";
    }
  }
}

# XXX: This is undocumented for now...
#
# =item B<import_methods NAME1 [, NAME2, ...]>
# 
# Import methods from the named class (the invocant) into the current class.
# This works by searching the class hierarchy, starting from the invocant class,
# and using a breadth-first search.  When an existing method with the requested
# NAME is found, it is aliased into the current (calling) package.  If a method
# of the desired name is not found, a fatal error is thrown.
# 
# This is a somewhat evil hack that i used internally to get around some
# inconvenient consequences of multiple inheritence and its interaction with
# Perl's default left-most depth-first method dispatch.
# 
# This method is an implementation detail and is not part of the public "user"
# API. It is described here for the benefit of those who are subclassing
# L<Rose::HTML::Object> and who also may find themselves in a bit of a multiple
# inheritence bind.
# 
# Example:
# 
#     package MyTag;
# 
#     use base 'SomeTag';
# 
#     use MyOtherTag;
# 
#     # Do a bredth-first search, starting in the class MyOtherTag,
#     # for methods named 'foo' and 'bar', and alias them into
#     # this package (MyTag)
#     MyOtherTag->import_methods('foo', 'bar');

# If method dispatch was breadth-first, I probably wouldn't need this...
sub import_methods
{
  my($this_class) = shift;

  my $options = ref $_[0] && ref $_[0] eq 'HASH' ? shift : {};

  my $target_class = $options->{'target_class'} || (caller)[0];

  my(@search_classes, @parents);

  @parents = ($this_class);

  while(my $class = shift(@parents))
  {
    push(@search_classes, $class);

    no strict 'refs';
    foreach my $subclass (@{$class . '::ISA'})
    {
      push(@parents, $subclass);
    }
  }

  my %methods;

  foreach my $arg (@_)
  {
    if(ref $arg eq 'HASH')
    {
      $methods{$_} = $arg->{$_}  for(keys %$arg);
    }
    else
    {
      $methods{$arg} = $arg;
    }
  }

  METHOD: while(my($method, $import_as) = each(%methods))
  {
    no strict 'refs';
    foreach my $class (@search_classes)
    {
      if(defined &{$class . '::' . $method})
      {
        #print STDERR "${target_class}::$import_as = ${class}::$method\n";
        *{$target_class . '::' . $import_as} = \&{$class . '::' . $method};
        next METHOD;
      }
    }

    Carp::croak "Could not find method '$method' in any subclass of $this_class";
  }
}

sub DESTROY { }

sub AUTOLOAD
{
  my($self) = $_[0];

  if(my $class = ref($self))
  {
    my $name = $AUTOLOAD;
    $name =~ s/.*://;

    if($class->html_attr_is_valid($name) && $class->autoload_html_attr_methods)
    {