package Class::Struct;
## See POD after __END__
use 5.006_001;
use strict;
use warnings::register;
our(@ISA, @EXPORT, $VERSION);
use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(struct);
$VERSION = '0.63';
## Tested on 5.002 and 5.003 without class membership tests:
my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
my $print = 0;
sub printem {
if (@_) { $print = shift }
else { $print++ }
}
{
package Class::Struct::Tie_ISA;
sub TIEARRAY {
my $class = shift;
return bless [], $class;
}
sub STORE {
my ($self, $index, $value) = @_;
Class::Struct::_subclass_error();
}
sub FETCH {
my ($self, $index) = @_;
$self->[$index];
}
sub FETCHSIZE {
my $self = shift;
return scalar(@$self);
}
sub DESTROY { }
}
sub import {
my $self = shift;
if ( @_ == 0 ) {
$self->export_to_level( 1, $self, @EXPORT );
} elsif ( @_ == 1 ) {
# This is admittedly a little bit silly:
# do we ever export anything else than 'struct'...?
$self->export_to_level( 1, $self, @_ );
} else {
goto &struct;
}
}
sub struct {
# Determine parameter list structure, one of:
# struct( class => [ element-list ])
# struct( class => { element-list })
# struct( element-list )
# Latter form assumes current package name as struct name.
my ($class, @decls);
my $base_type = ref $_[1];
if ( $base_type eq 'HASH' ) {
$class = shift;
@decls = %{shift()};
_usage_error() if @_;
}
elsif ( $base_type eq 'ARRAY' ) {
$class = shift;
@decls = @{shift()};
_usage_error() if @_;
}
else {
$base_type = 'ARRAY';
$class = (caller())[0];
@decls = @_;
}
_usage_error() if @decls % 2 == 1;
# Ensure we are not, and will not be, a subclass.
my $isa = do {
no strict 'refs';
\@{$class . '::ISA'};
=1= |