Class-Contract

 view release on metacpan or  search on metacpan

lib/Class/Contract.pm  view on Meta::CPAN

  }
  goto &Exporter::import;
}

sub unimport {
  my $class = shift;
  my $caller = caller;
  $contract{$caller}{use_old} = 0  if grep /^old$/, @_; 
}

sub contract(&) {  $_[0]->();  _build_class(caller) }

sub check(\%;$) {
# NOT IN PRODUCTION...
  my $state = !$#_ ? 0 : $_[1] ? 1 : 0;
  defined $_
    or croak("Usage:\n\tcheck \%sentinel",
       ($#_ ? " => $state" : ""),
       " for ( \@classes );\n\n");

  my $forclass = $_;
  $_[0]->{$forclass} =
    bless { 'prev'     => $no_opt{$forclass},

lib/Class/Contract.pm  view on Meta::CPAN

           'post'     => [], # NOT IN PRODUCTION
          }, "Class::Contract::$kind";

  # NOT IN PRODUCTION...
  $current->{'gentype'} = 'OBJECT'
    unless $current->{'gentype'} =~ /\A(SCALAR|ARRAY|HASH)\z/;
  # ...NOT IN PRODUCTION
  return $current;
}

sub attr($;$) { _member('attr'   => @_) }
sub method($) { _member('method' => @_) }
sub ctor(;$)  { _member('ctor'   => @_) }
sub dtor()    { _member('dtor') }
sub clon()    { _member('clone') }

sub scalar_attrs(@) { map _member('attr', $_, 'SCALAR'), @_ }
sub array_attrs(@)  { map _member('attr', $_, 'ARRAY'),  @_ }
sub hash_attrs(@)   { map _member('attr', $_, 'HASH'),   @_ }
sub methods(@)      { map _member('attr', $_),           @_ }

sub class(@)    { $_->{'shared'}   = 1  foreach(@_); @_ }
sub abstract(@) { $_->{'abstract'} = 1  foreach(@_); @_ }
sub private(@)  { $_->{'private'}  = 1  foreach(@_); @_ }

my %def_msg = (
  'pre'   => 'Pre-condition at %s failed',
  'post'  => 'Post-condition at %s failed',
  'invar' => 'Class invariant at %s failed',
  'impl'  => undef
);

sub _current {
  my ($field, $code) = @_;

lib/Class/Contract.pm  view on Meta::CPAN

  }
  
  $msg_target = $descriptor;
}

sub failmsg {
  croak "Unattached failmsg"  unless $msg_target;
  $msg_target->{'msg'} = shift;
}

sub pre(&)  { _current('pre'  => @_) }
sub post(&) { _current('post' => @_) }
sub impl(&) { _current('impl' => @_) }

sub optional { # my (@descriptors) = @_;
  $_->{'opt'} = 1  foreach(@_); @_ # NOT IN PRODUCTION
}

sub invar(&) {
  my ($code) = @_;

  my $descriptor = {
    'code'  => $code,
    'opt'   => 0,    # NOT IN PRODUCTION
    'msg'   => $def_msg{'invar'},
  };
  @{$descriptor}{qw(owner loc)} = _location;

  push @{$contract{$descriptor->{'owner'}}{'invar'}}, $descriptor;
  $msg_target = $descriptor;
}


sub inherits(@)  {
  my ($owner) = _location;
  foreach (@_) {
    croak "Can't create circular reference in inheritence\n$_ is a(n) $owner" 
      if $_->isa($owner)
  }
  push @{$contract{$owner}{'parents'}}, @_;
}

sub _build_class($) {
  my ($class) = @_;
  my $spec = $contract{$class};
  _inheritance($class, $spec);
  _attributes($class, $spec);
  _methods($class, $spec);
  _constructors($class, $spec);
  _destructors($class, $spec);
  _clones($class, $spec);
  1;
}

lib/Class/Contract/Production.pm  view on Meta::CPAN

  }
  goto &Exporter::import;
}

sub unimport {
  my $class = shift;
  my $caller = caller;
  $contract{$caller}{use_old} = 0  if grep /^old$/, @_; 
}

sub contract(&) {  $_[0]->();  _build_class(caller) }

sub check(\%;$) {
}


sub _location { # scalar context returns file and line of external code
                # array context returns package aka 'owner', file and line
  my ($i, @c, $owner);
  while (@c = (caller($i++))[0..2]) {
    if ($c[0] !~ /^Class::Contract::Production$/) {
      $owner = $c[0]  if !$owner;
      if ($c[1] !~ /^\(eval \d+\)$/) {

lib/Class/Contract/Production.pm  view on Meta::CPAN

           'type'     => $type || $def_type{$kind},
           'loc'      => $location,
           'shared'   => 0,
           'private'  => 0,
           'abstract' => 0,
          }, "Class::Contract::Production::$kind";

  return $current;
}

sub attr($;$) { _member('attr'   => @_) }
sub method($) { _member('method' => @_) }
sub ctor(;$)  { _member('ctor'   => @_) }
sub dtor()    { _member('dtor') }
sub clon()    { _member('clone') }

sub scalar_attrs(@) { map _member('attr', $_, 'SCALAR'), @_ }
sub array_attrs(@)  { map _member('attr', $_, 'ARRAY'),  @_ }
sub hash_attrs(@)   { map _member('attr', $_, 'HASH'),   @_ }
sub methods(@)      { map _member('attr', $_),           @_ }

sub class(@)    { $_->{'shared'}   = 1  foreach(@_); @_ }
sub abstract(@) { $_->{'abstract'} = 1  foreach(@_); @_ }
sub private(@)  { $_->{'private'}  = 1  foreach(@_); @_ }

my %def_msg = (
  'pre'   => 'Pre-condition at %s failed',
  'post'  => 'Post-condition at %s failed',
  'invar' => 'Class invariant at %s failed',
  'impl'  => undef
);

sub _current {
  my ($field, $code) = @_;

lib/Class/Contract/Production.pm  view on Meta::CPAN

  }
  
  $msg_target = $descriptor;
}

sub failmsg {
  croak "Unattached failmsg"  unless $msg_target;
  $msg_target->{'msg'} = shift;
}

sub pre(&)  { _current('pre'  => @_) }
sub post(&) { _current('post' => @_) }
sub impl(&) { _current('impl' => @_) }

sub optional { # my (@descriptors) = @_;
}

sub invar(&) {
  my ($code) = @_;

  my $descriptor = {
    'code'  => $code,
    'msg'   => $def_msg{'invar'},
  };
  @{$descriptor}{qw(owner loc)} = _location;

  push @{$contract{$descriptor->{'owner'}}{'invar'}}, $descriptor;
  $msg_target = $descriptor;
}


sub inherits(@)  {
  my ($owner) = _location;
  foreach (@_) {
    croak "Can't create circular reference in inheritence\n$_ is a(n) $owner" 
      if $_->isa($owner)
  }
  push @{$contract{$owner}{'parents'}}, @_;
}

sub _build_class($) {
  my ($class) = @_;
  my $spec = $contract{$class};
  _inheritance($class, $spec);
  _attributes($class, $spec);
  _methods($class, $spec);
  _constructors($class, $spec);
  _destructors($class, $spec);
  _clones($class, $spec);
  1;
}

t/Magic.pm  view on Meta::CPAN

  my $code = <SCRIPT>;
  $code =~ s/\n__(DATA|END)__\n.*//s;
  $code =~ s/\n\n=pod\n\n.*?(\n\n=cut\n\n|$)//gs;
  my (@count) = $code =~ /::ok/gs;
  return (1 + scalar @count);
}

my $count = 2;
my %history;

sub ok(%) {
  my %p = (@_); # code, expect, desc, version, need
  my $ok = 0;
  exists $p{'code'} or die "->ok(code => \\&) required!";
  $p{'desc'} ||= '';

  return printf("# skip %-2s %s (\$VERSION < %s)\n",
		$count++, $p{'desc'}, $p{'version'})
    if (exists $p{'version'} and $Class::Contract::VERSION < $p{'version'});

  return printf("# skip %-2s %s\n          (duplicate test description)\n",