=head1 NAME

class - classes and objects without packages

=head1 DESCRIPTION

class allows you to define class objects in a way that is similar to j
+avascript.
In this approach there is no difference between classes and objects so
+ I will only
use the word classes. class exports extends() and the variable $this b
+y default.

=over4

=item Defining classes

A new class can be created by using the new method

    my $class = new class sub{
        my $field = shift;
        $this->field = $field;
        $this->arrayref = [1,2,3];
        $this->hashref = {a => b, c => d};
        $this->method = sub{ return $this->field };
    };

A class can also be created by copying an existing class with its new(
+) method

    my $object = $class->new;

=item Accessing methods and attributes

You can access attributes and/or methods by using the class object fol
+lowed by an
arrow and the element name. Arrays and hashes are automatically derefe
+renced.

    print $class->name;
    print $class->name(LIST); # a method call with arguments

For attributes you can also use hash references.

    print $class->{name};

The elements() method can be used to access the code of a method. Used
+ for attributes
it is the same as using hash references.

    print $class->elements("name");


Note that a method that has already been defined can only be overridde
+n
by using the elements() method or hash references. Using $class->metho
+d will always
call the method instead of changing it.

=back

=head1 PREDEFINED METHODS

new(), can(), and elements() cannot be overridden.

    $class->new; # creates an independent clone
    $class->can("method"); # returns 1 if method is defined
    $class->elements; # returns number of elements

=head1 INHERITANCE

Within the class constructor it is possible to use class::extends() wh
+ich is
by default exported. If a method does not exist in the current class
it will be searched in the inherited classes.

    my $class = new class sub{
        extends($class1, $class2);
    };

=head1 STATIC DATA

Lexicals within the class constructor are static to methods that are d
+efined within
the constructor. That is not the case if you define a method outside t
+he constructor.

    my $class = new class sub{
        $this->field = shift;
        my $static = 1;
        $this->method = sub{ return $static };
        $this->increment = sub{ $static++ };
    };


=cut

##################################################
package class;
require Exporter;
use AutoLoader;
use strict;
use Carp;
use vars qw'$AUTOLOAD @EXPORT @ISA $this';
@ISA = qw(Exporter);
@EXPORT = qw(&extends $this);
$this = undef;

sub new{
    my $proto = shift;
    if(ref $proto){
        return new class($proto->{CONSTRUCTOR}, @_)
    }else{
        my $self = {};
        bless $self, $proto;
        $self->{EXTENDS} = [];
        $self->{CONSTRUCTOR} = shift;
        croak 'class expects CODE not ' . (ref($self->{CONSTRUCTOR})
|| 'string "'.$self->{CONSTRUCTOR}.'"') unless ref $self->{CONSTRUCTOR
+} eq 'CODE';
        my $savethis = ref($this) ? undef : $this;
        $this = local $$ = $self;
        $self->{CONSTRUCTOR}->(@_);
        $this = $savethis;
        return $self;
    }
}

##################################################
# Add inherited classes to $this->{EXTENDS}

sub extends{
    if(ref $$ ne 'class'){
        croak "Cannot extend outside a class";
    }
    my %done;
    foreach my $ext (@_){
        if(ref $ext ne 'class'){ croak 'class::extends expects a class
+ not '
. (ref($ext) || 'string "'.$ext.'"') }
        next if $done{scalar($ext)}++;
        push @{$$->{EXTENDS}}, $ext;
    }
}

##################################################
# Return all attributes in a class

sub elements : lvalue{
    my $self = shift;
    if(!@_){
        my %keys = %$self;
        delete $keys{CONSTRUCTOR};
        delete $keys{EXTENDS};
        my @keys = keys %keys;
        return @keys;
    }
    my $element = shift;
    return undef unless defined $element && exists $self->{$element};
    $self->{$element};
}

##################################################
# Look whether a method is defined or not

sub can{
    my $self = shift;
    my $can = shift;
    return undef unless defined $can;
    return 0 unless exists $self->{$can};
    return 0 unless ref($self->{$can}) eq 'CODE';
    1;
}

##################################################
# Link any subroutine call to data in $this.
# Seek in $this->{EXTENDS} if needed.

sub AUTOLOAD : lvalue{
    my $self = shift;
    $AUTOLOAD=~s/(.*):://;

    my $data;
    if(!exists $self->{$AUTOLOAD}){
        my @tree = @{$self->{EXTENDS}};
        my %done;
        while(@tree){
            $_ = shift @tree;
            next if $done{scalar($_)}++;
            unshift @tree, @{$_->{EXTENDS}};
            if(exists $_->{$AUTOLOAD}){
                $data = $_->{$AUTOLOAD};
                last;
            }
        }
        if(ref $$ eq 'class'){
            $self->{$AUTOLOAD} = undef unless defined $self->{$AUTOLOA
+D};
        }else{
            croak "Undefined attribute or method \"$AUTOLOAD\"" unless
+ defined $data;
        }
    }else{
        $data = $self->{$AUTOLOAD};
    }
    my $ref = ref $data;
    my $return;
    if($ref eq 'CODE'){
        my $savethis = ref($this) ? undef : $this;
        $this = local $$ = $self unless ref $$ eq 'class';
        $return = $data->(@_);
        $this = $savethis;
        return $return; # No lvalues
    }
    $ref eq 'ARRAY' ? (wantarray ? @{$self->{$AUTOLOAD}} : $self->{$AU
+TOLOAD}) :
    $ref eq 'HASH' ? (wantarray ? %{$self->{$AUTOLOAD}} : $self->{$AUT
+OLOAD}):
    $self->{$AUTOLOAD}
}

sub DESTROY{}

1;
[download]