view release on metacpan or  search on metacpan

lib/Mic/Assembler.pm  view on Meta::CPAN

    my $config_file = $ENV{MIC_CONTRACTS}
      or return;

    my $config = Config::Tiny->read($config_file);
    Mic::ContractConfig::configure($config);

    $self->{config_file_read} = 1;
}

sub _add_methods {
    my ($spec, $stash) = @_;

    my $in_interface = _interface($spec);

    $spec->{implementation}{methods}{DOES} = sub {
        my ($self, $r) = @_;

        if ( ! $r ) {
            my @items = (( $spec->{interface_name} ? $spec->{interface_name} : () ),
                          $spec->{name}, sort keys %{ $spec->{does} });
            return unless defined wantarray;
            return wantarray ? @items : \@items;
        }

        return    $r eq $spec->{interface_name}
               || $spec->{name} eq $r
               || $spec->{does}{$r}
               || $self->isa($r);
    };
    $spec->{implementation}{methods}{can} = sub {
        my ($self, $f) = @_;

        if ( ! $f ) {
            my @items = sort @{ $spec->{interface} };
            return unless defined wantarray;
            return wantarray ? @items : \@items;
        }
        return UNIVERSAL::can($self, $f);
    };

    while ( my ($name, $meta) = each %{ $spec->{implementation}{has} } ) {

        _validate_slot_def($meta);
        if ( !  $spec->{implementation}{methods}{ $meta->{reader} }
             && $meta->{reader}
             && $in_interface->{ $meta->{reader} } ) {

            $spec->{implementation}{methods}{ $meta->{reader} } = sub { 
                my ($self) = @_;

                return $self->[ $spec->{implementation}{slot_offset}{$name} ];
            };
        }

        if ( !  $spec->{implementation}{methods}{ $meta->{property} }
             && $meta->{property}
             && $in_interface->{ $meta->{property} } ) {

            confess "'property' can only be used from Perl 5.16 onwards"
              if $] lt '5.016';
            $spec->{implementation}{methods}{ $meta->{property} } = sub : lvalue {
                my ($self) = @_;

                return $self->[ $spec->{implementation}{slot_offset}{$name} ];
            };
        }

        if ( !  $spec->{implementation}{methods}{ $meta->{writer} }
             && $meta->{writer}
             && $in_interface->{ $meta->{writer} } ) {

            $spec->{implementation}{methods}{ $meta->{writer} } = sub {
                my ($self, $new_val) = @_;

                $self->[ $spec->{implementation}{slot_offset}{$name} ] = $new_val;
                return $self;
            };
        }
        _add_delegates($spec, $meta, $name);
    }

    while ( my ($name, $sub) = each %{ $spec->{implementation}{methods} } ) {
        next unless $in_interface->{$name};
        $stash->add_symbol("&$name", subname $stash->name."::$name" => $sub); 
    }

    foreach my $name ( @{ $spec->{interface} } ) {
        _add_pre_conditions($spec, $stash, $name, 'object');
        _add_post_conditions($spec, $stash, $name, 'object');
        _add_overloads($spec, $stash, $name, 'object');
    }
    _add_invariants($spec, $stash);
}

sub _validate_slot_def {
    validate(@_, {
        default  => { type => SCALAR   | CODEREF, optional => 1 },
        handles  => { type => ARRAYREF | HASHREF, optional => 1 },
        init_arg => { type => SCALAR, optional => 1 },
        property => { type => SCALAR, optional => 1 },
        reader   => { type => SCALAR, optional => 1 },
        writer   => { type => SCALAR, optional => 1 },
    });
}

sub _add_invariants {
    my ($spec, $stash) = @_;

    return unless $Mic::Contracts_for{ $spec->{name} }{invariant};
    my $inv_hash =
      (!  ref $spec->{interface}
       &&  $Mic::Spec_for{ $spec->{interface} }{interface_meta}{invariant})

      || $spec->{interface_meta}{invariant}
      or return;

    $spec->{invariant_guard} ||= sub {
        # skip methods called by the invariant
        return if (caller 1)[0] eq $spec->{name};