File Coverage

blib/lib/Class/SelfMethods.pm

Criterion	Covered	Total	%
statement	62	66	93.9
branch	19	22	86.3
condition	3	3	100.0
subroutine	12	12	100.0
pod	2	2	100.0
total	98	105	93.3

##############################################################################
#
# Class::SelfMethods - a Module for supporting instance-defined methods
#
# Author: Toby Ovod-Everett
# Last Change: Update POD to mention Class::Prototyped
##############################################################################
# Copyright 1999, 2003 Toby Ovod-Everett, 1999 Damian Conway.  All rights reserved.
#
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# For comments, questions, bugs or general interest, feel free to
# contact Toby Ovod-Everett at [e-mail]
#
# Damian Conway, [e-mail], was responsible for the _SET
# accessor code and the symbol table manipulation code.
##############################################################################

package Class::SelfMethods;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);

$VERSION = '1.08';

use Carp;

sub AUTOLOAD {
  (my $func = $AUTOLOAD) =~ s/^.*::(_?)//;
  unless ($1) {
    my $method = can($_[0], $func);
    goto &$method if $method;
  }
  croak sprintf 'Can\'t locate object method "%s" via package "%s"', $func, ref($_[0]);
}

sub can {
  my($self, $func) = @_;

  if ($func =~ s/_SET$//) {
    my $method = UNIVERSAL::can($self, "${func}_SET");
    unless ($method) {
      no strict;
      *{"${func}_SET"} = $method = sub { $_[0]->{$func} = $_[1] };
    }
    return $method;
  }

  if ($func =~ s/_CLEAR$//) {
    my $method = UNIVERSAL::can($self, "${func}_CLEAR");
    unless ($method) {
      no strict;
      *{"${func}_CLEAR"} = $method = sub { delete $_[0]->{$func} };
    }
    return $method;
  }

  my $undercall = "_$func";
  if (exists $self->{$func} or UNIVERSAL::can($self, $undercall)) {
    my $method = UNIVERSAL::can($self, $func);
    unless ($method) {
      no strict;
      *{$func} = $method = sub {
          if (exists $_[0]->{$func}) {
            if (ref ($_[0]->{$func}) eq 'CODE') {
              goto &{$_[0]->{$func}};
            } else {
              return $_[0]->{$func};
            }
          } else {
            my $self = shift;
            return $self->$undercall(@_);
          }
        };
    }
    return $method;
  }
  return;
}

sub new {
  my $class = shift;
  my(%params) = @_;

  my %temp_params;
  foreach my $i (keys %params) {
    if ($i =~ /^_/) {
      $temp_params{$i} = $params{$i};
      delete $params{$i};
    }
  }

  my $self = \%params;
  bless $self, $class;

  foreach my $i (keys %temp_params) {
    $self->$i(@{$temp_params{$i}});
  }

  return $self;
}

1;

__END__