/usr/local/CPAN/Language-Tea/Language/Tea/Environment.pm

• package Language::Tea::Environment
  • init_env
  • add_type
  • get_type
  • get_name
  • mangle
• EOF

package Language::Tea::Environment;

use strict;
use warnings;
use base qw(Language::Tea::Pad);

sub init_env {
    return Pad->new(
        outer     => undef,
        lexicals  => [],
        namespace => 'Main',
    );
}

sub add_type {
    my $Env  = shift;
    my $type = pop;
    my $name = join( '_', @_ );

    my $internal_name = mangle($name);
    my $old_type      = get_type( $Env, $name );
    my $new_type      = $type;

    #print "Old type: $old_type ; New type: $new_type \n";
    if ( defined $old_type
        && $old_type ne $new_type )
    {

        #die "Type Redefinition";
        $internal_name .= '_' . ( 1000 + int( rand(9000) ) ) . '_';
    }

    $Env->add_lexicals(
        [ '$' . mangle($name) . "_TYPE_", '$' . mangle($name) . "_NAME_", ] );
    my $cmd = '$'
      . mangle($name)
      . "_TYPE_ = '"
      . mangle($type) . "'; " . '$'
      . mangle($name)
      . "_NAME_ = '"
      . $internal_name . "'; ";

    #print "Env add_type: $cmd\n";
    $Env->eval($cmd);
}

sub get_type {
    my $Env  = shift;
    my $name = join( '_', @_ );
    my $cmd  = '$' . mangle($name) . "_TYPE_";
    my $type;
    local $@;
    if ( $Env->declaration($cmd) ) {

        #print "Env: $cmd\n";
        $type = $Env->eval($cmd);

        #print "Type = ", $type, "\n";
    }
    else {
        $cmd  = '$' . mangle( $_[0] );    # look for a default type
                                          #print "Env(2): $cmd\n";
        $type = $Env->eval($cmd);

        #print "Type = ", $type, "\n";
    }
    $type = undef if $@;
    return $type;
}

sub get_name {
    my $Env  = shift;
    my $name = join( '_', @_ );
    my $cmd  = '$' . mangle($name) . "_NAME_";
    my $type;
    local $@;
    if ( $Env->declaration($cmd) ) {

        #print "Env: $cmd\n";
        $type = $Env->eval($cmd);

        #print "Name = ", $type, "\n";
    }
    return $type if defined $type;
    return mangle($name);    # make a default name
}

sub mangle {
    my $s = shift;
    Carp::confess unless defined $s;
    $s =~ s/ ([^a-zA-Z0-9_<>]) / '_'.ord($1).'_' /xge;
    return $s;
}

1;