File Coverage

blib/lib/Class/Struct/FIELDS.pm

Criterion	Covered	Total	%
statement	449	466	96.3
branch	84	144	58.3
condition	15	78	19.2
subroutine	130	130	100.0
pod	1	2	50.0
total	679	820	82.8

package Class::Struct::FIELDS;

require 5.005_64;
use strict;
use warnings::register;

use Carp;

# AutoLoader would be nice, but it mucks up with evaling the package
# definitions in 'struct'.  Hmmm.

use AutoLoader qw(AUTOLOAD);
use base qw(Exporter);

# Items to export into callers namespace by default. Note: do not
# export names by default without a very good reason. Use EXPORT_OK
# instead.  Do not simply export all your public
# functions/methods/constants.

# This allows declaration use Class::Struct::FIELDS ':all'; If you do
# not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

our %EXPORT_TAGS = (all => [qw(struct)]);
our @EXPORT_OK = (@{$EXPORT_TAGS{all}});
our @EXPORT = qw(struct);

# I'd like to say "our $VERSION = v1.1;", but MakeMaker--even in perl
# 5.6.0--, doesn't grok that and has trouble creating a Makefile.
our $VERSION = '1.1';
my $rcs = qq$Id: FIELDS.pm,v 1.1.1.1 2001/04/08 23:28:31 binkley Exp $;

# my %SEEN_PKGS = ();

sub struct;

sub _array ($$;$);
sub _arraytie ($$);
sub _arrayref ($$;$);
sub _code ($$;$);
sub _coderef ($$;$);
sub _baseclass_warning ($$);
sub _get_isa ($$);
sub _hash ($$;$);
sub _hashtie ($$);
sub _hashref ($$;$);
sub _mini_prolog ($$);
sub _new_new_warning ($);
sub _object ($$$$;$);
sub _array_object ($$$$;$);
sub _hash_object ($$$$;$);
sub _objectref ($$$$;$);
sub _override_warning ($$);
sub _postlog ( );
sub _prolog ($$$);
sub _regexp ($$;$);
sub _regexpref ($$;$);
sub _scalar ($$;$);
sub _scalarref ($$;$);
sub _stringify ( );
sub _usage_error;

# Preloaded methods go here.

sub import {
  my ($class) = shift;

  # We consume all of @_, so don't pass it along.
  $class->export_to_level (1);

  # Consume our own frame so that &struct thinks our caller is the
  # real caller.
  goto &struct if @_;
}

sub struct {
  my ($class, $isa, $decls);
  my $caller = caller;

  if (my $ref = ref $_[0]) { # guess class from caller
    if ($ref eq 'ARRAY') {
      if ($ref = ref $_[1]) {
	if ($ref eq 'HASH') { # called as "{LIST}, [LIST]"
	  ($class, $isa, $decls) = ($caller, shift, shift);
	  _usage_error if @_;
	}

	else {
	  _usage_error;
	}
      }

      else { # called as "[LIST], LIST"
	($class, $isa, $decls) = ($caller, shift, {@_});
      }
    }

    elsif ($ref eq 'HASH') { # called as "{LIST}"
      ($class, $isa, $decls) = ($caller, [], shift);
      _usage_error if @_;
    }

    else {
      _usage_error;
    }
  }

  else { # caller listed
    if ($ref = ref $_[1]) {
      if ($ref eq 'ARRAY') {
	if ($ref = ref $_[2]) {
	  if ($ref eq 'HASH') { # called as "[LIST], {LIST}"
	    ($class, $isa, $decls) = (shift, shift, shift);
	    _usage_error if @_;
	  }

	  else {
	    _usage_error;
	  }
	}

	else { # called as "[LIST], LIST"
	  ($class, $isa, $decls) = (shift, shift, {@_});
	}
      }

      elsif ($ref eq 'HASH') { # called as "CLASS, {LIST}"
	($class, $isa, $decls) = (shift, [], shift);
	_usage_error if @_;
      }

      else {
	_usage_error;
      }
    }

    else {
      if (@_) {
	if (@_ % 2) { # called as "LIST" with CLASS
	  ($class, $isa, $decls) = (shift, [], {@_});
	}

	else { # called as "LIST" without CLASS
	  ($class, $isa, $decls) = ($caller, [], {});
	}
      }

      else { # called as plain "&struct"
	($class, $isa, $decls) = ($caller, [], {});
      }
    }
  }

  eval _mini_prolog ($class, $isa); # baseclass warnings
  my $eval = _prolog ($class, $isa, $decls);

  # Automagic overload support.
  $eval .= _stringify
    if (do { no strict qw(refs); exists &{"$class\::as_string"} });

  while (my ($k, $v) = each %$decls) {
    my $hidden = undef;

    # Don't make subroutines for "private" keys; you should access
    # them directly: $self->{_blah_blah};  See fields.
    next if $k =~ /^_/o;

    # Check for three cases:
    #
    # 1. Caller has already defined an accessor.
    #
    # 2. Base class has a same-named method.
    #
    # 3. Take care to use exists instead of defined so that caller can
    #    use sub declarations before actually defining the access
    #    method.

    if (do { no strict qw(refs); exists &{"$class\::$k"} }) {
      _override_warning ($class, $k);
      $hidden = 1;
      # next;
    }

    # This doesn't work?  XXX
    _baseclass_warning ($class, $k) if UNIVERSAL::can ($class, $k);

    if ($v eq '$') {
      $eval .= _scalar ($class, $k, $hidden);
    }

    elsif ($v eq '\$' or $v eq '*$') {
      $eval .= _scalarref ($class, $k, $hidden);
    }

    elsif ($v eq '@') {
      $eval .= _array ($class, $k, $hidden);
    }

    # EXPERIMENTAL  XXX
    elsif ($v eq '+@') {
      $eval .= _arraytie ($class, $k);
      $eval .= _array ($class, $k, $hidden);
    }

    elsif ($v eq '\@' or $v eq '*@') {
      $eval .= _arrayref ($class, $k, $hidden);
    }

    elsif ($v eq '%') {
      $eval .= _hash ($class, $k, $hidden);
    }

    # EXPERIMENTAL  XXX
    elsif ($v eq '+%') {
      $eval .= _hashtie ($class, $k);
      $eval .= _hash ($class, $k, $hidden);
    }

    elsif ($v eq '\%' or $v eq '*%') {
      $eval .= _hashref ($class, $k, $hidden);
    }

    elsif ($v eq '&') {
      $eval .= _code ($class, $k, $hidden);
    }

    elsif ($v eq '\&' or $v eq '*&') {
      $eval .= _coderef ($class, $k, $hidden);
    }

    elsif ($v eq '/') {
      $eval .= _regexp ($class, $k, $hidden);
    }

    elsif ($v eq '\/' or $v eq '*/') {
      $eval .= _regexpref ($class, $k, $hidden);
    }

    # EXPERIMENTAL  XXX
    elsif ($v =~ s/^\+@(\w+(?:::\w+)*)$/$1/o) {
#       $SEEN_PKGS{$class}->{$k} = $v;
      $eval .= _arraytie ($class, $k);
      $eval .= _array_object ($class, $caller, $k, $v, $hidden);
    }

    # EXPERIMENTAL  XXX
    elsif ($v =~ s/^@(\w+(?:::\w+)*)$/$1/o) {
#       $SEEN_PKGS{$class}->{$k} = $v;
      $eval .= _array_object ($class, $caller, $k, $v, $hidden);
    }

    # EXPERIMENTAL  XXX
    elsif ($v =~ s/^\+%(\w+(?:::\w+)*)$/$1/o) {
#       $SEEN_PKGS{$class}->{$k} = $v;
      $eval .= _hashtie ($class, $k);
      $eval .= _hash_object ($class, $caller, $k, $v, $hidden);
    }

    # EXPERIMENTAL  XXX
    elsif ($v =~ s/^%(\w+(?:::\w+)*)$/$1/o) {
#       $SEEN_PKGS{$class}->{$k} = $v;
      $eval .= _hash_object ($class, $caller, $k, $v, $hidden);
    }

    elsif ($v =~ s/^[\\*](\w+(?:::\w+)*)$/$1/o) {
#       $SEEN_PKGS{$class}->{$k} = $v;
      $eval .= _objectref ($class, $caller, $k, $v, $hidden);
    }

    elsif ($v =~ /^\w+(?:::\w+)*$/o) {
#       $SEEN_PKGS{$class}->{$k} = $v;
      $eval .= _object ($class, $caller, $k, $v, $hidden);
    }

    else {
      _usage_error;
    }
  }

  $eval .= _postlog;

  eval $eval;
  carp $@ if $@;

  $class;
}

# Work around a broken UNIVERSAL::isa in 5.6.0:
if ($^V eq v5.6.0) {
  no warnings;

  # sub UNIVERSAL::isa {
  sub isa {
    my ($class, $super) = @_;
    $class = ref $class || $class;
    return 1 if $class eq $super; # trivial case

    my $f = sub {
      no strict qw(refs);

      my ($class, $super, $g) = @_;
      my @supers = @{"$class\::ISA"};

      foreach my $s (@supers) {
	return 1 if $s eq $super;
	# Does Perl optimizer understand tail recursion?
	return $g->($s, $super, $g);
      }

      return '';
    };

    return $f->($class, $super, $f);
  }

  *UNIVERSAL::isa = \&isa;
}

sub _get_isa ($$) {
  my ($class, $isa) = @_;
  my @isa;

  {
    no strict qw(refs);

    @isa = (@{"$class\::ISA"}, @$isa); # preserve the existing @ISA
  }

  return @isa;
}

sub _mini_prolog ($$) {
  my ($class, $isa) = @_;
  my @isa = _get_isa ($class, $isa);

  <
{
  package $class;
  use base qw(@isa);
}
EOC
}

sub _prolog ($$$) {
  my ($class, $isa, $decls) = @_;
  my @isa = _get_isa ($class, $isa);
  my @fields = keys %$decls;

  <
{
  package $class;

  require 5.005_64;
  use strict;
  use warnings;

  use Carp;

  use base qw(@isa);
  use fields qw(@fields);

  # Allow user to provide their own new as long as they return
  # \$self->_init (\@_);
  unless (do { no strict qw(refs); exists &{$class\::new} }) {
    *{$class\::new} = sub {
      my \$this = shift;
      my \$class = ref \$this || \$this || __PACKAGE__;
      my $class \$self = fields::new (\$class);

      \$self->_init (\@_);
    };
  }

  else {
    Class::Struct::FIELDS::_new_new_warning ('$class');
  }

  # Two-step initialization so that user-defined init's will have the
  # parents' fields all ready to go.  This relies on cooperation from
  # sub new.
  sub _init {
    my $class \$self = shift;
    my \%init = \@_;

    # Simple solution for now.  Some problems:
    #
    # 1. Diamond inheritance can call _init multiple times.  I don't
    # know if it's a good thing, or a bad thing, but fields forbids
    # multiple inheritance.
    #
    # 2. Member initialization gets called every time through.

    for (qw(@isa)) {
      eval { bless \$self, \$_; \$self = \$self->_init (\@_) };
    }

    bless \$self, qw($class);

    # Init our fields to be like Class::Struct.  According to the
    # documentation for fields, the call to fields::new should have
    # set up our parents as well, so that we can init their fields
    # too.  Make sure to call the accessors so that user-defined ones
    # are invoked (instead of assigning directly to the pseudo-hash.)
    {
      no strict qw(refs);

      # Only invoke valid keys; pass the rest through unmolested.
      my \$c;

      while (my (\$k, \$v) = each \%init) {
        \$self->\$c (\$v) if \$c = $class\::->can (\$k);
      }
    }

    eval { \$self = \$self->init (\@_) }; # if \$self->can ('init');

    \$self;
  }
EOC
}

sub _postlog ( ) {
  <

  1;
}
EOC
}

1;

# Autoload methods go after __END__, and are processed by the
# autosplit program.

__END__