#! /usr/bin/env perl

# This is a (mostly) direct translation of the lua.c driver from the
# Lua 5.1.4 distribution.  It has not been truly Perlyfied.

use strict;
use warnings;

use Lua::API;
use IO::Handle;

my $globalL;

my $progname = 'lua';

main();


##############################################################
# lua.c uses a few non-public things defined in luaconf.h
# they're emulated here.

sub LUA_QL { return "'" . shift() . "'" };

sub lua_stdin_is_tty { 1; }

{
    package Lua::API::State;
    use Term::ReadLine;

    my $term;

    INIT { $term = Term::ReadLine->new( 'lua' ); }

    sub readline {

	my ( $L, $b, $prompt ) = @_;

	my $line = $term->readline( $prompt );

	if ( defined $line )
	{
	    $$b = $line;
	    return 1;
	}

	return 0;
    }

    sub saveline {

	my ( $L, $idx ) = @_;

	if ( $L->strlen($idx) > 0 ) # non-empty line
	{
	    $term->addhistory( $L->tostring($idx) );
	}

    }

    sub freeline { }

    sub assert {}
}

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


sub lstop  {

    my ( $L, $ar) = @_;

    $L->sethook( undef, 0, 0);

    $L->error( "interrupted!");

}


sub laction {

    $SIG{'INT'} = 'DEFAULT';	     # if another SIGINT happens before lstop,
                                     # terminate process (default action)
    $globalL->sethook( lstop, Lua::API::MASKCALL | Lua::API::MASKRET | Lua::API::MASKCOUNT, 1);
}


sub print_usage {

    print STDERR
      "usage: $0 [options] [script [args]].\n",
	"Available options are:\n" .
	  "  -e stat  execute string " . LUA_QL("stat") . "\n" .
	  "  -l name  require library " . LUA_QL("name") . "\n" .
	  "  -i       enter interactive mode after executing " . LUA_QL("script") . "\n" .
	  "  -v       show version information\n" .
	  "  --       stop handling options\n" .
	  "  -        execute stdin and stop handling options\n"
	  ;

}


sub l_message  {

    my ( $pname, $msg) = @_;

    print STDERR "$pname: "
      if defined $pname;

    print STDERR "$msg\n";
}


sub  report {
    my ( $L, $status) = @_;

    if ($status && !$L->isnil(-1))
    {
	my $msg = $L->tostring(-1);
	$msg = "(error object is not a string)"
	  if ! defined $msg;
	l_message( $progname, $msg);
	$L->pop( 1);
    }
  return $status;
}


sub traceback  {

    my ( $L ) = @_;

    return 1
      if (! $L->isstring(1));	# 'message' not a string? keep it intact

    $L->getfield( Lua::API::GLOBALSINDEX, "debug");

    if (! $L->istable(-1))
    {
	$L->pop( 1);
	return 1;
    }

    $L->getfield(-1, "traceback");

    if (! $L->isfunction( -1))
    {
	$L->pop(2);
	return 1;
    }

    $L->pushvalue(1);		# pass error message
    $L->pushinteger(2);	# skip this function and traceback
    $L->call( 2, 1);		# call debug.traceback
    return 1;
}


sub  docall {
    my ( $L, $narg, $clear ) = @_;

    my $base = $L->gettop() - $narg;   # function index
    $L->pushcfunction( \&traceback );  # push traceback function
    $L->insert( $base);                # put it under chunk and args

    $SIG{'INT'} = \&laction;

    my $status = $L->pcall( $narg, ($clear ? 0 : Lua::API::MULTRET), $base);
    $SIG{'INT'} = 'DEFAULT';
    $L->remove( $base);                # remove traceback function

    # force a complete garbage collection in case of errors
    $L->gc( Lua::API::GCCOLLECT, 0)
      if $status != 0;
    return $status;
}


sub print_version {
  l_message(undef, Lua::API::RELEASE . "  " . Lua::API::COPYRIGHT);
}


sub getargs {

    my ($L, $argv, $n) = @_;

    my $narg = @$argv - ($n + 1);	# number of arguments to the script

    $L->checkstack( $narg + 3, "too many arguments to script");

    $L->pushstring( $argv->[$_]) for ( $n+1 .. @$argv-1 );

    $L->createtable( $narg, $n+1);

    for my $i ( 0..@$argv-1)
    {
	$L->pushstring( $argv->[$i]);
	$L->rawseti( -2, $i - $n);
    }
    return $narg;
}


sub dofile {
    my ($L, $name) = @_;

    my $status = $L->loadfile( $name) || docall( $L, 0, 1);
    return report( $L, $status );
}


sub dostring {
    my ( $L, $s, $name) = @_;

    my $status = $L->loadbuffer( $s, length($s), $name) || docall( $L, 0, 1);

    return report( $L, $status );
}


sub  dolibrary {
    my ( $L, $name) = @_;

    $L->getglobal( "require");
    $L->pushstring( $name);
    return report( $L, docall( $L, 1, 1));
}


sub get_prompt {
    my ( $L, $firstline) = @_;

    $L->getfield( Lua::API::GLOBALSINDEX, $firstline ? "_PROMPT" : "_PROMPT2");
    my $p = $L->tostring( -1);
    $p = ($firstline ? '> ' : '>> ')
      if ! defined $p;
    $L->pop( 1);  # remove global
    return $p;
}


sub incomplete {
    my ( $L, $status) = @_;

  if ( $status == Lua::API::ERRSYNTAX) 
  {
      my $lmsg;
      my $msg = $L->tolstring( -1, \$lmsg);

      my $eof = LUA_QL("<eof>");
      if ( $msg =~ /$eof$/ )
      {
	  $L->pop( 1);
	  return 1;
      }
  }
  return 0;  # else...
}


sub pushline {
    my ($L, $firstline) = @_;

    my $b;

    my $prmt = get_prompt( $L, $firstline);

    return 0  # no input
      if $L->readline( \$b, $prmt) == 0;

    chomp $b;
    my $l = length( $b );

    if ( $firstline && substr($b, 0, 1 ) eq '=')  # first line starts with `=' ?
    {
	$L->pushfstring( "return %s", $b+1);  # change it to `return'
    }
    else
    {
	$L->pushstring( $b );
    }
    $L->freeline( $b );

    return 1;
}


sub loadline {
    my ( $L ) = @_;
    $L->settop( 0);

    return -1			# no input
      if ! pushline( $L, 1 );

    my $status;

    for (;;)
    {				# repeat until gets a complete line
	$status = $L->loadbuffer( $L->tostring( 1), $L->strlen( 1), "=stdin");

	last if !incomplete( $L, $status ); # cannot try to add lines?
	return -1
	  if !pushline( $L, 0);	# no more input?

	$L->pushliteral( "\n"); # add a new line...
	$L->insert( -2);	# ...between the two lines
	$L->concat( 3);		# join them
    }
    $L->saveline( 1);
    $L->remove( 1);		# remove line
    return $status;
}


sub dotty { 
    my ( $L ) = @_;

    my $oldprogname = $progname;
    $progname = undef;

    my $status;

    while (( $status = loadline( $L )) != -1)
    {
	$status = docall( $L, 0, 0)	if $status == 0; 
	report( $L, $status);
	if ($status == 0 && $L->gettop > 0)
	{			# any result to print?
	    $L->getglobal( "print");
	    $L->insert( 1);
	    if ($L->pcall( $L->gettop-1, 0, 0) != 0)
	    {
		l_message($progname, 
			  $L->pushfstring("error calling " . LUA_QL("print") ." (%s)",
					  $L->tostring( -1)));
	    }

	}
    }
    $L->settop(0);		# clear stack
    print STDOUT "\n";
    STDOUT->flush;
    $progname = $oldprogname;

    return;
}


sub handle_script {

    my ( $L, $argv, $n)  = @_;

    my $narg = getargs( $L, $argv, $n); # collect arguments

    $L->setglobal( "arg");
    my $fname = $argv->[$n];

    if ( $fname eq '-' && $argv->[$n-1] ne "--")
    {
	$fname = undef;		# stdin
    }

    my $status = $L->loadfile( $fname);

    $L->insert( -($narg+1));

    if ( $status == 0 )
    {
	$ status = docall( $L, $narg, 0);
    }
    else
    {
	$L->pop( $narg);
    }
    return report( $L, $status);
}


sub collectargs {
    my ( $argv, $pi, $pv, $pe) = @_;

    for ( my $i = 0 ; $i < @$argv ; $i++ )
    {

	if ( substr( $argv->[$i], 0, 1 ) ne '-' ) # not an option?
	{  return $i; }

	my $opt = substr( $argv->[$i], 1, 1 );

	if ( $opt eq '-' )
	{
	    return -1 if length( $argv->[$i] ) != 2;
	    return ( @$argv > $i+1 ? $i+1 : 0);
	}

	elsif ( ! defined $opt )
	{
	    return $i;
	}

	elsif ( $opt eq 'i' )
	{
	    return -1 if length( $argv->[$i] ) != 2;
	    $$pi = 1;
	    $$pv = 1;
	}

	elsif ( $opt eq 'v' )
	{
	    return -1 if length( $argv->[$i] ) != 2;
	    $$pv = 1;
	}

	elsif ( $opt eq 'e' || $opt eq 'l' )
	{
	    $$pe = 1 if $opt eq 'e';

	    if ( length($argv->[$i]) == 2)
	    {
		$i++;
		return -1 if @$argv == $i;
	    }
	}
	else
	{
	    return -1;		# invalid option
	}
    }
    return 0;
}


sub runargs {
    my ( $L, $argv, $n ) = @_;

    for (my $i = 0; $i < $n; $i++)
    {
	next if ( ! defined $argv->[$i] );

	$L->assert( $argv->[$i] =~ /^-/ );

	if ( $argv->[$i] =~ /^-e/ )
	{
	    my $chunk = substr( $argv->[$i], 2 );
	    $chunk = $argv->[++$i] if length($chunk) == 0;

	    $L->assert( length($chunk) );

	    if (dostring( $L, $chunk, "=(command line)") != 0)
	      { return 1; }
	}

	elsif ( $argv->[$i] =~ /^-l/ )
	{
	    my $filename = substr( $argv->[$i], 2 );
	    $filename = $argv->[++$i] if length($filename) == 0;

	    $L->assert( length($filename) );

	    if (dolibrary( $L, $filename))
	      { return 1; }		# stop if file fails
	}
    }
    return 0;
}


sub handle_luainit  {

    my ( $L ) = @_;

    if ( ! defined $ENV{LUA_INIT} ) # status OK
    {
	return 0;
    }
    elsif ( $ENV{LUA_INIT} =~ /^@/ )
    {
	return dofile( $L, substr($ENV{LUA_INIT}, 1) );
    }
    else
    {
	return dostring( $L, $ENV{LUA_INIT}, "=" . 'LUA_INIT');
    }
}


sub pmain {
    my ( $L )  = @_;

    my $s = $L->touserdata(1);

    my $argv = $s->{argv};

    my ( $has_i, $has_v, $has_e );

    $globalL = $L;

    $progname = $0;
    if ( @$argv && length($argv->[0]))
    {
	$L->gc( Lua::API::GCSTOP, 0); # stop collector during initialization
    }

    $L->openlibs;		# open libraries
    $L->gc( Lua::API::GCRESTART, 0);
    $s->{status} = handle_luainit( $L );

    return 0 if $s->{status} != 0;

    my $script = collectargs( $argv, \$has_i, \$has_v, \$has_e);

    if ($script < 0)
    {				# invalid args?
	print_usage();
	$s->{status} = 1;
	return 0;
    }

    print_version() if $has_v;

    $s->{status} = runargs( $L, $argv, ($script > 0) ? $script : scalar @$argv);

    return 0 if $s->{status} != 0;

    if ($script)
    {
	$s->{status} = handle_script( $L, $argv, $script);
    }

    return 0 if $s->{status} != 0;

    if ($has_i)
    {
	dotty( $L );
    }
    elsif ( $script == 0 && !$has_e && !$has_v)
    {
	if ( lua_stdin_is_tty() )
	{
	    print_version();
	    dotty($L);
	}
	else
	{
	    dofile( $L );		# executes stdin as a file
	}
    }
    return 0;
}


sub  main  {


  my $L = Lua::API::State->open();  # create state

  if (! defined $L ) {
    l_message($0, "cannot create state: not enough memory");
    return 1;
  }

  my %s = ( argc => scalar @ARGV,
	    argv => \@ARGV );

  my $status = $L->cpcall( \&pmain, \%s);

  report( $L, $status);

#  $L->close;

  return ($status || $s{status}) ? 1 : 0 ;
}