view release on metacpan or  search on metacpan

typesafety.pm  view on Meta::CPAN

#    or possible start to most deeply nested ops and work outwards, but we might miss prototypes etc.
#    move to tracking return values to and from each seq() number?
#    or, if we're fully recursive, we could walk the op tree ourselves, just going sibling to sibling
#    at the top level, recursing into the depths. yeah, i like that. okey, that's what we've done.
# v/ $a->meth() - $methods{$scalars->{targ of $a}->type()}->{'meth'} should exist, period, or we're trying to
#    call an unprototyped method.
# v/ when multiple things are declared on one line, they each still get their own nextstate.
#    this means we need only process them in the same order. each could link to the next.
#    was being silly about this. now the "declare" subs are just stubs and we extract original
#    data from the bytecode tree.
# v/ drop attributes, perhaps, and use proto() for scalars too. prototype proto():
#    declare FooBar => my $a; 
#    didn't drop attributes, but we added declare().
# v/ use ->sibling() rather than ->next() to skip over sub-expressions when parsing B - in SOME places
# v/ declare() needs B parser logic to back it up
# v/ beware looking for nextstate! makes compound instructions impossible!
# v/ inspect methods in all modules, not just root level main
# v/ CHECK { } is too soon - inserting code into the main tree at CHECK time might be the best solution.
#    scalar attributes and proto() are done runtime, so our check routine would have to be triggered
#    from the end?! just before the main loop? hrm. don't know how this is going to work. manual call
#    for now.

use 5.8.8;
use strict;
no strict 'refs';
use warnings;
our $VERSION = '0.05';

use B;
use B::Generate;

#
# constants
#

use B qw< ppname >;
use B qw< OPf_KIDS OPf_STACKED OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST >;
use B qw< OPpTARGET_MY >;
use B qw< SVf_IOK SVf_NOK SVf_POK SVf_IVisUV >;
sub SVs_PADMY () { 0x00000400 }     # use B qw< SVs_PADMY >;

#
# variables
#

my %knownuniverse; # all known namespaces - our inspection list
my %args;          # use-time arguments
my $debug = 0;     # debug mode flag
our $curcv;        # codevalue to get pad entries from
our $returnvalue;  # typeob expected of returns, if any

my $lastline; my $lastfile; my $lastpack;  # set from COP statements as we go 

#
# debugging
#

use Carp 'confess', 'cluck';
use B::Concise 'concise_cv';

sub debug { my @args = @_; my $line = (caller)[2]; print "debug: $line: ", @args, "\n" if $debug; }

sub nastily () { " in package $lastpack, file $lastfile, line $lastline"; }

# $SIG{__DIE__} =  $SIG{INT} = sub {
#    # when someone does kill -INT <our pid> from the command line, dump our stack and exit
#    print STDERR shift, map { (caller($_))[0] ? sprintf("%s at line %d\n", (caller($_))[1,2]) : ''; } 0..30;
#    print STDERR join "\n", @_;
#    exit 1;
# };

#
# allow user to specify what types ought to be
#

sub import {
  my $caller = caller;
  $args{$_}++ foreach @_;
  $debug = $args{debug};
  push @{$caller.'::ISA'}, 'typesafety'; 
  $knownuniverse{$caller}++; 
  *{$caller.'::proto'} = sub {
     my $method = shift;
     die qq{proto syntax: proto 'foo', returns => 'FooBar', takes => 'FooBar', undef, 'FooBar', 'BazQux', undef, undef, undef;\n}
       unless 'returns' eq shift; 
     my $type = shift;
     my $takes = [];
     if(@_) {
       die unless 'takes' eq shift; 
       $takes = [ @_ ];
     }
     (undef, my $filename, my $line) = caller(0); # XX nasty hardcode
     die "filename" unless $filename; die "line" unless $line;
     my $typeobject = typesafety::methodob->new(
          type=>$type, package=>$caller, filename=>$filename, line=>$line, 
          name=>$method, desc=>'prototyped method', takes=>$takes,
     );
     $typeobject->literal = $type if $method eq 'new'; # shift_prototype() for new() returns identity. bless looks for lit in this.
     define_method($caller, $method, $typeobject);
  };
  *{$caller.'::declare'} = sub :lvalue { 
    $_[1] 
  };
  return 1;
}

#
# data structures
#

{

  my $methods;       # $methods->{$package}->{$methodname} = typeob
  my $scalars;       # $scalars->{$curcv}->{$targ} = typeob

  sub lookup_method {
    my $package = shift;
    my $method = shift;
    return exists $methods->{$package} if ! defined $method;
    return $methods->{$package}->{$method} if defined $package and defined $method and exists $methods->{$package} and exists $methods->{$package}->{$method};
    return undef;

typesafety.pm  view on Meta::CPAN

     $op->can('targ') and 
     # ppname($op->targ()) eq 'pp_list' and
     $op->flags() & OPf_KIDS and
     $op->can('first')
   ) {
     debug('denull descending past null op ', ppname($op->targ()), ' to: ', $op->first()->name());
     $op = $op->first();
     return denull($op);
   }

   return $op;

}

sub source_status { return ($lastpack, $lastfile, $lastline) }


#
# typeob
#

# represents a type itself, including where it was defined, how it was defined, and how it is actually used.
# type data associated with a typed scalar - includes verbose information about where the type was defined
# for good diagnostics in case of error

package typesafety::typeob;

# accessors

sub type     :lvalue { $_[0]->[0] }          # point of our existance
sub package  :lvalue { $_[0]->[1] }          # diagnostic output in case of type match failure
sub filename :lvalue { $_[0]->[2] }          # diagnostics
sub line     :lvalue { $_[0]->[3] }          # diagnostics
sub pad      :lvalue { $_[0]->[4] }          # scalars only 
sub name     :lvalue { $_[0]->[5] }          # scalars only 
sub desc     :lvalue { $_[0]->[6] }          # scalar or method return? diagnostics? creating info?
sub takes    :lvalue { $_[0]->[7] }          # in the case of methods, what types (in order) do we take for args?

sub accepts  { [] }                          # 8 - typesafety::arrayob does something with this
sub emits    { [] }                          # 9 - noop in this base class
sub accept   { }                             # noop in this base class
sub emit     { }                             # noop in this bsae class

sub literal  :lvalue { $_[0]->[10] }         # literal value stored in scalar, if known. new's prototype is reused as prototype first arg to new.
sub created  :lvalue { $_[0]->[11] }         # internal debugging - which program line called the constructor


sub argnum     { typesafety::confess }       # 12 - next arg to be read, methodobs
sub subobjects { typesafety::confess }       # 12 - hashes contain other invidually typed objects

sub reset_prototype  { typesafety::confess } # typesafety::methodob 
sub shift_prototype  { typesafety::confess } # typesafety::methodob 
sub aelem_prototype  { typesafety::confess } # typesafety::methodob 

sub new { 
  my $self = bless ['none', typesafety::source_status(), (undef) x 4, [], [], undef], shift(); 
  while(@_) { 
    my $f = shift; $self->$f = shift; 
  } 
  # ignore the output string, just make sure that the fields required for diagnostics are defined
  $self->created = (caller)[2]; 
  $self->diagnostics(); 
  typesafety::debug("typesafety::typeob: new: created ", $self->diagnostics());
  return $self; 
}

sub clone { 
  my $self = shift; 
  my @new = @$self; 
  # augment description - this is the primary (only?) change made to clones
  $new[6] ||= ''; $new[6] .= ' ' . $_[0] if @_;  
  typesafety::debug("new desc is $new[6]");
  # typesafety::cluck("new desc");
  bless \@new, ref $self;
}

sub diagnostics { 
  my $self = shift;
  my @diag;
  push @diag, $self->desc if $self->desc;
  push @diag, $self->name if $self->name; # typesafety::confess unless $self->name;
  push @diag, 'type ' . $self->type if $self->type; # typesafety::confess unless $self->type;
  push @diag, 'containing the literal value "' . $self->literal . '"' if defined $self->literal;
Carp::confess "strange crap in 'takes'" if $self->takes and ref($self->takes) ne 'ARRAY';
  push @diag, 'taking as arguments the types "' . join(', ', map $_||'(undef)', @{ $self->takes }) . '"' if $self->takes and ref($self->takes) eq 'ARRAY';
  push @diag, 'created inside typesafety by request from line ' . $self->created if $debug;
  push @diag, sprintf 'defined in package %s, file %s, line %s', $self->package, $self->filename, $self->line if $self->package or $self->filename;
  return join ', ', @diag;
}

sub isa {
  # wrapper for the normal UNIVERSAL::isa() test - should two typeobs not match, we die with diagnostics
  my $self = shift; 
  my $arewe = shift or typesafety::confess(); 
  ref $arewe or typesafety::confess(); 
  my $fatal = shift; 
  return 1 if ! $self->type();  # despite having a type object, they're untyped... this happens with methods prototyped to (undef; ...)
  return 1 if ! $arewe->type();  # despite having a type object, we're untyped... this happens with methods prototyped to (undef; ...)
  return 1 if $self->type() eq $arewe->type() or $self->type()->isa($arewe->type()); 
  return undef unless $fatal;
  die join ' ', $fatal, ($fatal?': ':''),  "type mismatch: expected: ", $arewe->diagnostics(), 
                "; got: ", $self->diagnostics(), typesafety::nastily(); 
}

package typesafety::scalarob; 

use base 'typesafety::typeob'; 

sub typesafety::scalarob::stuff { 'scalar' }

#
# typesafety::methodob
#

package typesafety::methodob; 

use base 'typesafety::typeob'; 

sub typesafety::methodob::stuff { 'method' }

sub argnum    :lvalue { $_[0]->[12] }   # next argument position to be read