296 lines
6.9 KiB
Perl
296 lines
6.9 KiB
Perl
package PerlRPG::Script;
|
|
use strict;
|
|
require Exporter;
|
|
use SDL;
|
|
use SDL::Event;
|
|
use SDLx::App;
|
|
use SDLx::Sprite;
|
|
use SDLx::Sprite::Animated;
|
|
use PerlRPG::Console;
|
|
use PerlRPG::Game;
|
|
use PerlRPG::Assets;
|
|
use PerlRPG::Drawing;
|
|
|
|
use vars qw/@ISA @EXPORT @EXPORT_OK/;
|
|
@ISA = qw/Exporter/;
|
|
@EXPORT = qw/CompileScripts RunScript RunScriptTick GetGameVar SetGameVar DefGameVar EvalString/;
|
|
@EXPORT_OK = @EXPORT;
|
|
|
|
my %labels;
|
|
my $current_file;
|
|
my $current_line;
|
|
|
|
my %script_commands = (
|
|
'Wait' => {'sub' => sub {}, 'wait' => 1},
|
|
'AddSayer' => {'sub' => \&AddSayer, 'wait' => 0},
|
|
'Define' => {'sub' => \&DefGameVar, 'wait' => 0},
|
|
'ExitGame' => {'sub' => \&PerlRPG::Game::ExitGame, 'wait' => 1},
|
|
|
|
'Jump' => {'sub' => \&PerlRPG::Script::RunScript, 'wait' => 0},
|
|
|
|
'Show' => {'sub' => \&PerlRPG::Drawing::ShowSprite, 'wait' => 0},
|
|
'Hide' => {'sub' => \&PerlRPG::Drawing::HideSprite, 'wait' => 0},
|
|
'SetBackground' => {'sub' => \&PerlRPG::Drawing::SetBackgroundColor, 'wait' => 0},
|
|
|
|
'ScanDirectory' => {'sub' => \&PerlRPG::Assets::ScanDirectory, 'wait' => 0},
|
|
'LoadAssets' => {'sub' => \&PerlRPG::Assets::LoadAssets, 'wait' => 0},
|
|
'UnloadAsset' => {'sub' => \&PerlRPG::Assets::UnloadAsset, 'wait' => 0},
|
|
'SetAssetOption' => {'sub' => \&PerlRPG::Assets::SetAssetOption, 'wait' => 0},
|
|
);
|
|
|
|
my %sayers = ();
|
|
my $lastsayer=undef;
|
|
|
|
my %game_vars = ();
|
|
|
|
sub GetGameVar {
|
|
my $key = shift(@_);
|
|
if(exists $game_vars{$key}) {
|
|
return $game_vars{$key};
|
|
}
|
|
LogData(WARN, "GetGameVar($key): Unknown variable");
|
|
return undef;
|
|
}
|
|
|
|
sub IsString {
|
|
return 1 if($_[0]=~/^\s*".+"\s*$/);
|
|
}
|
|
|
|
sub SetGameVar {
|
|
my($key, $val)=@_;
|
|
if(exists $game_vars{$key}) {
|
|
return $game_vars{$key} = StringSubst($val);
|
|
}
|
|
LogData(WARN, "SetGameVar($key): Unknown variable");
|
|
return undef;
|
|
}
|
|
|
|
# It is legal to Define a game variable twice, value will not be reset
|
|
sub DefGameVar {
|
|
my($key, $val)=@_;
|
|
if(!exists $game_vars{$key}) {
|
|
$game_vars{$key} = StringSubst($val);
|
|
}
|
|
}
|
|
|
|
# Load script files, locate labels
|
|
sub CompileScripts {
|
|
my @scripts = sort { $a cmp $b } LoadAssets('gs');
|
|
%labels = ();
|
|
|
|
foreach my $name (@scripts) {
|
|
my $ref = GetAsset($name);
|
|
for(my $line = 0; $line < @$ref-0; $line++) {
|
|
my($lbl)=$ref->[$line]=~/^\s*(\S+):\s*$/;
|
|
if($lbl) {
|
|
$labels{$lbl} = {
|
|
'File' => $name,
|
|
'Line' => $line,
|
|
};
|
|
LogData(DEBUG, "Found script label '$lbl' at $name:$line");
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Setup script to run
|
|
sub RunScript {
|
|
my($label)=@_;
|
|
|
|
if(exists $labels{$label}) {
|
|
$current_file = $labels{$label}{'File'};
|
|
$current_line = $labels{$label}{'Line'};
|
|
LogData(DEBUG, "RunScript($label) moving to $current_file:$current_line");
|
|
} else {
|
|
LogData(ERROR, "RunScript($label) unknown label");
|
|
}
|
|
}
|
|
|
|
# Run script from current position until a wait condition
|
|
sub RunScriptTick {
|
|
return 1 if($lastsayer);
|
|
for(;;) {
|
|
my $script = GetAsset($current_file); # current_file can change in RunScriptLine, so reload each time
|
|
my $file = $current_file;
|
|
my $line = $current_line++;
|
|
if($line >= @$script) {
|
|
LogData(ERROR, "Script file ended");
|
|
SetOption('Running', 0);
|
|
return;
|
|
}
|
|
if(RunScriptLine($file, $line, $script->[$line])) {
|
|
return;
|
|
}
|
|
}
|
|
};
|
|
|
|
# Returns true if a wait condition is seen
|
|
sub RunScriptLine {
|
|
my($file, $linenum, $line)=@_;
|
|
|
|
# Copy to refer to
|
|
my $oline = $line;
|
|
|
|
# Remove comments
|
|
$line=~s/#.+$//; # Remove comments
|
|
$line=~s/^\s+//; # Remove leading whitespace
|
|
$line=~s/\s+$//; # Remove trailing whitespace
|
|
|
|
if($line=~/^\s*\S+:\s*$/ || $line=~/^\s+$/ || !$line) {
|
|
# Label or blank, skip
|
|
return 0;
|
|
}
|
|
|
|
my($cmd, @opts)=split(/\s+/, $line);
|
|
LogData(DEBUG, "$file:$linenum $cmd(" . join(',',@opts) . ")");
|
|
if(exists $script_commands{$cmd}) {
|
|
$script_commands{$cmd}{'sub'}->(@opts);
|
|
return $script_commands{$cmd}{'wait'};
|
|
} elsif(exists $sayers{$cmd}) {
|
|
my($text)=$oline=~/\Q$cmd\E\s+(".+?")\s*$/;
|
|
if($text) {
|
|
return SayLine($sayers{$cmd}, $text);
|
|
} else {
|
|
LogData(ERROR, "Invalid sayer text in script at $file:$linenum");
|
|
return;
|
|
}
|
|
} elsif(my($key,$val)=$line=~/^\s*(\S+)\s*=\s*(.+?)\s*$/) {
|
|
LogData(DEBUG, "Setting '%s' to '%s'", $key, $val);
|
|
return SetGameVar($key, $val);
|
|
}
|
|
|
|
LogData(ERROR, "Unknown command '$cmd' in script at $file:$linenum");
|
|
return undef;
|
|
}
|
|
|
|
sub AddSayer {
|
|
my($name, $displayname, $sprite, @textcolor)=@_;
|
|
if(@textcolor < 4) {
|
|
$textcolor[3] = 255;
|
|
}
|
|
|
|
$sayers{$name} = {
|
|
'Name' => $name,
|
|
'DisplayName' => StringSubst($displayname),
|
|
'Sprite' => $sprite,
|
|
'TextColor' => \@textcolor
|
|
};
|
|
}
|
|
|
|
sub EvalString {
|
|
my $val = shift(@_);
|
|
# Perform math calculations and the like
|
|
|
|
# Check for simple numbers
|
|
if(my($v) = $val=~/^\s*(\d+)\s*$/) {
|
|
return $v;
|
|
}
|
|
|
|
#LogData(DEBUG, "Doing complex Eval");
|
|
# Ensure spacing around tokens
|
|
while(my($full,$f,$o,$s)=$val=~/((\S)([+-\/\*\(\)\.])(\S))/) {
|
|
#LogData(DEBUG, "Replacing '$full' with '$f $o $s'");
|
|
$val=~s/\Q$full\E/$f $o $s/;
|
|
}
|
|
while(my($full,$f,$o)=$val=~/((\S)([+-\/\*\(\)\.]))\s/) {
|
|
#LogData(DEBUG, "Replacing '$full' with '$f $o'");
|
|
$val=~s/\Q$full\E/$f $o/;
|
|
}
|
|
while(my($full,$o,$s)=$val=~/\s(([+-\/\*\(\)\.])(\S))/) {
|
|
#LogData(DEBUG, "Replacing '$full' with '$o $s'");
|
|
$val=~s/\Q$full\E/$o $s/;
|
|
}
|
|
if($val=~/^[+-\/\*\(\)\.]\S/) {
|
|
substr($val, 1, 0)=' ';
|
|
#LogData(DEBUG, "Inserting space after initial character");
|
|
}
|
|
if($val=~/\S[+-\/\*\(\)\.]$/) {
|
|
substr($val, -1, 0)=' ';
|
|
#LogData(DEBUG, "Inserting space before last character");
|
|
}
|
|
|
|
LogData(DEBUG, "Val is '$val'");
|
|
|
|
# Tokenize
|
|
my @tokens = split(/\s+/,$val);
|
|
|
|
|
|
for(my $i=0;$i<@tokens-0;$i++) { LogData(DEBUG, "Pass 1 Token [%i], '%s'", $i, $tokens[$i]); }
|
|
|
|
for(my $i=0;$i<@tokens-0;$i++) {
|
|
my $t = $tokens[$i];
|
|
if($i < @tokens-1 && $tokens[$i+1] eq '(') {
|
|
# This is a function call; Don't replace it
|
|
} elsif(exists $game_vars{$t}) {
|
|
# Token matches a game var, replace it
|
|
$tokens[$i] = GetGameVar($t);
|
|
} elsif(IsString($tokens[$i])) {
|
|
# Looks like a string, Call StringSubst on it
|
|
$tokens[$i] = '"' . StringSubst($tokens[$i]) . '"';
|
|
}
|
|
}
|
|
|
|
for(my $i=0;$i<@tokens-0;$i++) { LogData(DEBUG, "Pass 2 Token [%i], '%s'", $i, $tokens[$i]); }
|
|
|
|
my $eval_str = '$eval_res = ' . join(' ', @tokens) . ';';
|
|
LogData(DEBUG, "About to eval '$eval_str'");
|
|
my $eval_res;
|
|
eval $eval_str;
|
|
if($@) {
|
|
LogData(ERROR, "Error in eval: $@");
|
|
return 0;
|
|
}
|
|
LogData(DEBUG, "Got result of '$eval_res'");
|
|
return $eval_res;
|
|
}
|
|
|
|
sub StringSubst {
|
|
my $text=shift(@_);
|
|
|
|
if(!IsString($text)) {
|
|
return EvalString($text);
|
|
}
|
|
($text)=$text=~/^\s*"(.+)"\s*$/;
|
|
|
|
while(my($f,$n)=$text=~/(\[(\S+)\])/) {
|
|
my $v=GetGameVar($n);
|
|
if(!defined $v) {
|
|
$v = '!!INVALID!!';
|
|
}
|
|
$text=~s/\Q$f\E/$v/g;
|
|
}
|
|
|
|
$text=~s/\\n/\n/g;
|
|
return $text;
|
|
}
|
|
|
|
sub SayLine {
|
|
my($ref, $text)=@_;
|
|
LogData(DEVALL, "%s saying \"%s\"", $ref->{'DisplayName'}, $text);
|
|
|
|
$text = StringSubst($text);
|
|
DrawSpeech($ref, $text);
|
|
$lastsayer = $ref;
|
|
return 1;
|
|
}
|
|
|
|
sub SkipText {
|
|
$lastsayer = undef;
|
|
HideSprite('_SayerText');
|
|
HideSprite('_SayerSprite');
|
|
}
|
|
|
|
|
|
1;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|