Language::Basic - Perl Module to interpret BASIC

    use Language::Basic;

    my $Program = new Language::Basic::Program;
    $Program->input("program.bas"); # Read lines from a file
    $Program->parse; # Parse the Program
    $Program->implement; # Run the Program
    $Program->output_perl; # output Program as a Perl program

    $Program->line("20 PRINT X"); # add one line to existing Program

package Language::Basic;
# by Amir Karger (See below for copyright/license/etc.)

use strict;
require 5.004; # I use 'foreach my'
use IO::File;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
);

# Stolen from `man perlmod`
$VERSION = do { my @r = (q$Revision: 1.44 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

# Sub-packages
use Language::Basic::Common;
use Language::Basic::Expression;
use Language::Basic::Function;
use Language::Basic::Statement;
use Language::Basic::Token;
use Language::Basic::Variable;

# sub-packages
{
package Language::Basic::Program;
package Language::Basic::Line;
}

######################################################################

{
package Language::Basic::Program;
use Language::Basic::Common;

# Fields:
# lines		Keys are line numbers, values are LB::Line objects
# curr_line	LB::Line currently being implemented/parsed/whatever
# end_program	Done implementing the program?
# stack		The subroutine stack. In BASIC, it's just a list of
# 		statements we GOSUB'ed from.
# data		The data holder (stuff from DATA statements, read by READ)
# parsed	Has this Program been parsed since the last time 
#		new lines were added?
# needed_subs	Functions whose perl-equivalent subs we need to print out 
#		at the end of the program. (Keys are names of subs, values
#		are sub descriptions.)
# column	Current column of the screen the program is printing to
sub new {
    my ($class, $infile) = @_;

    #Initialize the intrinsic functions
    &Language::Basic::Function::Intrinsic::initialize();

    my $in = {
	"lines" => {},
        "curr_line" => undef,
	"end_program" => 0,
        'stack' => [],
	"for_statements" => {},
        'data' => [],
        'parsed' => 0,
	"needed_subs" => {},
	"column" => 0,
    };
    bless $in, $class;
} # end sub Language::Basic::Program::new

my $_Current_Program; # Gasp! It's an Evil Global Variable!
sub current_program {
    return $_Current_Program;
}
sub set_current_program {
    my $self = shift or die "LBP::set_current_program must have argument!\n";
    $_Current_Program = $self;
}

sub current_line { return shift->{"curr_line"}; }
sub set_current_line {
    my $prog = shift; 
    my $num = shift;
    if (defined $num && exists $prog->{"lines"}->{$num}) {
	$prog->{"curr_line"} = $prog->{"lines"}->{$num};
    } else {
        $prog->{"curr_line"} = undef;
    }
}
sub first_line_number {return (sort {$a <=> $b} keys %{shift->{"lines"}})[0]; }

sub current_line_number {
    my $prog = shift;
    my $line = $prog->current_line;
    return (defined $line ? $line->line_number : undef);
}

sub input {
    my ($self, $filename) = @_;
    $self->set_current_program;
    my $fh = new IO::File $filename;
    die "Error opening $filename: $!\n" unless defined $fh;
    my $old_num = -1;

    while (<$fh>) {
        next if /^\s*$/; # empty lines
	chomp;

	# Line Number
	my $line_num = $self->_add_line($_);
	defined $line_num
	    or die "Missing line number " .
		($old_num > 0 ? "after line $old_num\n" : "on first line\n");

	# In input files, we make sure lines are in numerical order. 
	# If they're not, it's most likely a bug.
	# Same is not true for a Term::Readline interpreter
	if ($line_num <= $old_num) {
	    die "Line $line_num: lines in file must be in increasing order.\n";
	}

	$old_num = $line_num;
    }
    close ($fh);

    # order the lines
    $self->_fix_lines;
    $self->{'parsed'} = 0;

} # end sub Language::Basic::Program::input

sub line {
    my $self = shift;
    $self->set_current_program;
    my $line = shift; # sans \n

    defined $self->_add_line($line) or die "Missing line number in line()!\n";
    $self->_fix_lines;
    $self->{'parsed'} = 0;
} # end sub Language::Basic::Program::line

sub _add_line {
    # takes the line (sans \n), returns the line number read or undef if there
    # is none.
    # You must call _fix_lines between _add_line and returning to the
    # user's program!

    my $self = shift;
    my $line = shift;

    # Line Number
    $line =~ s/^\s*(\d+)\s+// or return;
    my $line_num = $1;

    # Create an LB::Line with what's left of the line
    $self->{'lines'}{$line_num} = new Language::Basic::Line($line, $line_num);

    return $line_num;
} # end sub Language::Basic::Program::_add_line

# fix the ordering of the lines in the program
sub _fix_lines {
    my $self = shift;

    my @line_numbers = sort {$a <=> $b} keys %{$self->{"lines"}};

    for (my $i = 0; $i < @line_numbers - 1; $i++) { # process all but last
	my $line = $self->{'lines'}{ $line_numbers[$i] };
	$line->set_next( $line_numbers[ $i+1 ] );
    } 

    $self->{'lines'}{ $line_numbers[-1] }->set_next( undef );
} # end sub Language::Basic::Program::_fix_lines 

sub parse {
    my $self = shift;
    $self->set_current_program;

    return if $self->{'parsed'};

    $self->set_current_line($self->first_line_number);

    # Loop through the lines in the program, parse each
    while (defined (my $line = $self->current_line)) {
	#print $line->line_number," ",$line->{"text"},"\n";
	$line->parse;
	$self->set_current_line($line->get_next);
    }

    $self->{'parsed'} = 1;
} # end sub Language::Basic::Program::parse

sub implement {
    my $self = shift;
    $self->set_current_program;
    # In case you're lazy & call implement w/out parsing first
    $self->parse unless $self->{'parsed'};

    # Zero stack, etc., start at beginning of program
    $self->start;
    # Mini-kludge to get the program running
    $self->goto_line($self->current_line_number);

    # Loop over statements while there are statements
    while (defined(my $curr_statement = $self->increment)) {

	# TODO create a "trace" command that prints out line numbers
	# for debugging
	#my $line = $self->current_line;
	#print $line->line_number," ",$line->{"text"},"\n";

	# Do the statement!
	# Hooray for OO; just call "implement" on everything!
	#print "Statement class ",ref($curr_statement),"\n";
	# Note that this may well change where the next &increment will go
	$curr_statement->implement;
    }

    #Done!
    # TODO Exit more gracefully?
} # end sub Language::Basic::Program::implement

# Return the next Statement we're supposed to execute, based on the Program's
# next_statement field. And set the default action for the subsequent call
# to increment, which is to do the next Statement in order. (Or return
# undef if the program is done.)
#
# In the simplest case, next_statement will just be the Statement after the
# current one on the current Line, although it my well be in a totally
# different place due to GOTOs, RETURNs, ELSEs or other interesting programming
# tools.
#
# If next_statement is undefined, we're done with this line (and haven't been
# directed to go somewhere more interesting), so go to the next line in order.
#
# TODO should this method be podded?
sub increment {
    my $self = shift;

    my $next;
    unless (defined($next = $self->{"next_statement"})) {
	# Program is at the end of a line
	my $line = $self->current_line;
	my $number = $line->get_next;

	# goto_line will set Program's next_statement
	# ($number = undef will set "end_program")
	$self->goto_line($number);
	$next = $self->{"next_statement"};
    }
    # Did we hit an END or "fall off" the last line of the program?
    return undef if $self->{"end_program"};

    # By default, we're going to go on to the next statement after this one
    $self->{"next_statement"} = $next->{"next_statement"};

    # Whether or not we were at end of line, we now know what next
    # Statement is, so return it.
    return $next;

}

# Don't erase "data". It's set during parsing.
sub start {
    my $self = shift;
    $self->{"stack"} = [];
    $self->{"for_statements"} = {};
    $self->{"column"} = 0;

    # Start on the first line of the program
    $self->set_current_line($self->first_line_number);
} # end sub Language::Basic::Program::start

sub goto_line {
    my $self = shift;
    my $next_line = shift;

    if (defined $next_line) {
	$self->set_current_line($next_line);
        my $line = $self->current_line or
	    Exit_Error("Can't find line $next_line!");
	$self->{"next_statement"} = $line->{"first_statement"};
    } else {
        $self->{"end_program"} = 1;
    }

} # end sub Language::Basic::Program::set_next_line

sub goto_after_statement {
    my $self = shift;
    my $st = shift;
    $self->{"next_statement"} = $st;
    # May have jumped to (the beginning or middle of) a new line,
    # so we have to reset this. (It stays the same if we're jumping w/in
    # one line, but that's OK.)
    $self->set_current_line($st->{"line_number"});

    # Goto the statement, and set Program's next_statement field, so
    # that when Program::implement calls increment, it goes to the
    # statement *after* this one.
    $self->increment;

} # end sub Language::Basic::Program::goto_after_statement

sub push_stack {
    my $self = shift;
    my $st = shift;
    push @{ $self->{'stack'} }, $st;
}

sub pop_stack {
    my $self = shift;
    return pop @{ $self->{'stack'} };
}

sub store_for {
    my $self = shift;
    my $for_statement = shift;
    my $lvalue = $for_statement->{"lvalue"};
    my $name = $lvalue->{"name"};
    $self->{"for_statements"}->{$name} = $for_statement;
} # end sub Language::Basic::Program::store_for

sub get_for {
    my $self = shift;
    my $next_statement = shift;
    my $lvalue = $next_statement->{"lvalue"};
    my $name = $lvalue->{"name"};
    if (exists $self->{"for_statements"}->{$name}) {
        return $self->{"for_statements"}->{$name};
    } else {
	Exit_Error("NEXT $name without FOR!");
    }
} # end sub Language::Basic::Program::get_for

sub add_data {
    my $self = shift;
    my $thing = shift;
    push @{ $self->{'data'} }, $thing;
}

sub get_data {
    my $self = shift;
    @{ $self->{'data'} } or Exit_Error("More items READ than input in DATA!");
    my $thing = shift @{ $self->{'data'} }; 
    return $thing;
}

sub output_perl {
    my $self = shift;
    $self->set_current_program;
    # In case you're lazy & call implement w/out parsing first
    $self->parse unless $self->{'parsed'};

    my $sep = '#' x 78;
    # TODO these variables should be changeable by switches to basic2pl!
    my $spaces_per_indent = 4;
    # Indenting for outputted Perl
    my $Output_Indent = 2; # eight spaces by default

    # Beginning of the program
    # TODO should basic2pl do these two lines?
    print '#!/usr/bin/perl -w';
    print "\n#Translated from BASIC by basic2pl\n\n";

    if (@{$self->{"data"}}) {
	print "$sep\n# Setup\n#\n";
	print "# Read data\n";
        print "while (<DATA>) {chomp; push \@Data, \$_}\n\n";
    }

    # Zero program stack, etc., start at beginning of program
    $self->start;

    # Loop through the lines in the program
    print "$sep\n# Main program\n#\n";
    while (defined (my $line = $self->current_line)) {
	my $line_num = $line->line_number;
	#warn "Line $line_num\n";
	my $label = "L$line_num:";

	# What's the line?
	my $out = $label . $line->output_perl;
	
	# Print labels all the way against the left edge of the line,
	# then indent the rest of the line.
	# Split with -1 so final \n's don't get ignored
	foreach (split (/\n/, $out, -1)) {
	    # Change indenting for next time?
	    $Output_Indent += 1, next if $_ eq "INDENT";
	    $Output_Indent -= 1, next if $_ eq "UNINDENT";
	    warn "weird indenting $Output_Indent\n" if $Output_Indent < 2;

	    # If we didn't hit an indent-changing command, print the
	    # label (if any) and the actual string
	    # TODO only print out the labels we have to!
	    $label = (s/^A?L\d+:// ? $& : "");
	    # minus for left justify
	    my $indent = -$Output_Indent * $spaces_per_indent; 
	    printf("%*s", $indent, $label);

	    # print the actual string
	    print $_;
	    print "\n"; # the \n we lost from split, or the last \n
	}

	# Go through lines in order
	$self->set_current_line($line->get_next);
    }

    # TODO why not indent these nicely?
    my $n = $self->{"needed_subs"};
    print "\n$sep\n# Subroutine Definitions\n#\n" if %$n;
    # Print out required subroutines
    foreach (sort keys %$n) {
        my $out = join(" ", "sub", $_, $n->{$_}, "# end sub $_\n\n");
	$Output_Indent = 0;

	foreach (split (/\n/, $out, -1)) {
	    # Change indenting for next time?
	    $Output_Indent += 1, next if $_ eq "INDENT";
	    $Output_Indent -= 1, next if $_ eq "UNINDENT";
	    warn "weird indenting $Output_Indent\n" if $Output_Indent < 0;

	    # If we didn't hit an indent-changing command, print the string
	    my $indent = $Output_Indent * $spaces_per_indent; 
	    print " " x $indent;

	    # print the actual string
	    print $_;
	    print "\n"; # the \n we lost from split, or the last \n
	}
    }

    # If there were any DATA statements...
    if (@{$self->{"data"}}) {
        print "\n\n$sep\n# Data\n#\n__DATA__\n";
	print join("\n", map {$_->output_perl} @{$self->{"data"}});
	print "\n";
    }
} # end sub Language::Basic::Program::output_perl

sub need_sub {
    my $self = shift;
    my $n = $self->{"needed_subs"};
    my ($func_name, $func_desc) = @_;
    return if exists $n->{$func_name};
    $n->{$func_name} = $func_desc;
} # end sub Language::Basic::Program::need_sub

} # end package Language::Basic::Program

######################################################################

{
package Language::Basic::Line;
use Language::Basic::Common;

# Make a new LB::Line with the text given (don't parse it yet)
sub new {
    my $class = shift;
    my $text = shift;
    my $line_number = shift;
    my $in = {
	# literal text of the line (not including line number)
	"text" => $text,
	# Pointer to first LB::Statement on the line
	"first_statement" => 0,
	# number of next line (accessed with set/get_next)
	'next_line' => undef,
	# BASIC line number of this Line
	"line_number" => $line_number,
    };
    bless $in, $class;
} # end sub Language::Basic::Line::new

sub line_number { shift->{"line_number"} }

sub get_next { return shift->{'next_line'}; }

# TODO Should this be _set_next and undocumented? Only gets called by _fix_lines
sub set_next {
    my $self = shift;
    my $next = shift;

    $self->{'next_line'} = $next;
} # end sub Language::Basic::Line::set_next

sub parse {
    my $self = shift;

    # Break the line up into Tokens for later eating/parsing
    my $token_group = new Language::Basic::Token::Group;
    $token_group->lex($self->{"text"});
    my $oldst;

    # Parse Statement(s) in the Line
    do {
	# Create the new Statement and figure out what kind of statement it
	# is.  $statement will be an object of a subclass LB::Statement::*)
	my $statement = new Language::Basic::Statement $token_group;

	# Actually parse the Statement
	$statement->parse($token_group);

	# Each statement needs to know which line it's on, in case we
	# RETURN or NEXT into the middle of a line.
	$statement->set_line_number($self->{"line_number"});

	# Create a linked list of the Statements in the line
        if (defined $oldst) {
	    $oldst->{"next_statement"} = $statement
	} else {
	    $self->{"first_statement"} = $statement;
	}
	$oldst = $statement;

    # If there's a colon, eat it and parse the next Statement on the Line
    } while ($token_group->eat_if_class("Statement_End"));

    # TODO make this error prettier
    if ($token_group->stuff_left) {
        my $p = "Extra tokens left after parsing!\n" . $token_group->print;
	chomp($p);
	Exit_Error($p);
    }
}

sub output_perl {
    my $self = shift;
    my $statement = $self->{"first_statement"};
    my $out = $statement->output_perl;
    # Do each statement in the line in order
    # Put each statement on a separate line.
    while (defined ($statement = $statement->{"next_statement"})) {
	$out .= "\n";
	$out .= $statement->output_perl;
    }

    # Output the statement
    return $out;
} # end sub Language::Basic::Line::output_perl

} # end package Language::Basic::Line


# end package Language::Basic
1;

__END__
# More Docs