Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SCRMGR.ZIP/SCRPRIM.PAS

Pascal/Delphi Source File | 1992-11-04 | 10.7 KB | 419 lines

{$A+,F+,R-,S-,V-,X+}

{***************************************************}
{*                SCRPRIM.PAS 1.00                 *}
{*        Primitives for Script management         *}
{*      Steve Sneed, TurboPower Software 1992      *}
{*          Released to the public domain          *}
{*  Requires TP6 & Object Professional to compile  *}
{***************************************************}

(*

  This unit implements a simple script language manager.  Based on the script
  parser in OzCIS, it is built on the "one statement per line" principle,
  similar to the DOS batch language.  It's overall design allows much more
  complex script parsers to be developed, however.

  In a nutshell: the entire script file is loaded into a DoubleList object.
  Script execution starts at the head of the list by retrieving the first
  active line and parsing it, and repeating the process as needed.  Labels
  are declared as in the DOS batch language, a word or phrase (no spaces) that
  starts with a colon (:), on a line by itself.  The JUMP (GOTO) command scans
  the list looking for the appropriate label, and when found, resets CurP to
  that line and continues.

  GOSUB works differently: each node of the list contains a byte variable
  (Level) that is initialized to 0.  The list object itself also has a byte
  field (CurLevel) that is initialized to 0.  When a GOSUB command is
  encountered, CurLevel is incremented and the GOSUB command line's Level
  variable is set to CurLevel, and the list is searched for the GOSUB label
  using the same logic as GOTO.  When a RETURN command is encountered, the
  list is scanned for a node with a Level value = CurLevel; if found, CurP is
  set to that node, the node's Level variable is reset to 0 and CurLevel is
  decremented.  This scheme allows up to 255 nested levels of GOSUB and an
  unlimited number of GOSUBs within one script.

  With this engine, one important virtual method must be overridden: the
  ProcessLine function.  The script manager gets each line of the script in
  turn and calls ProcessLine, passing the line in question.  ProcessLine's
  job is to do whatever the line commands in your script language, returning
  True if successful or False if the script should abort.  Under this system
  your language can be a very simplistic, one-statement-per-line scheme or a
  more complex token-based language; what and how the parser does it's actual
  work is up to you.

*)

unit ScrPrim;  {primitives for script file management}

interface

uses
  DOS,
  OpInline,
  OpDos,
  OpRoot,
  OpString;

const
  {command constants}
  scGoTo   = 997;
  scGoSub  = 998;
  scReturn = 999;

const
  CommentChar = ';';

type
  {one line of a script}
  PStr = ^String;
  PLine = ^SLine;
  SLine =
    object(DoubleListNode)
      LP    : PStr;
      Level : Byte;

      constructor Init(S : String);
      destructor Done; virtual;
    end;

  {our script manager}
  ScriptPtr = ^ScriptMgr;
  ScriptMgr =
    object(DoubleList)
      CurP       : PLine;
      CurLevel   : Byte;
      Running    : Boolean;

      {...initialization and virtual methods}
      constructor Init;
        {-instantiate our script manager object}
      destructor Done; virtual;
        {-dispose of object when done}
      function ProcessLine(S : String) : Boolean; virtual;
        {-process a line of the script. *MUST BE OVERRIDDEN*}
      procedure Process; virtual;
        {-run the script}
      procedure PrepareLine(var S : String); virtual;
        {-allows pre-processing a line before adding it to the list}

      {...other public methods}
      function LoadScript(FN : PathStr) : Boolean;
        {-load a script file into the manager}
      function LoadSubScript(FN : PathStr) : Boolean;
        {-load a secondary script and GOSUB to it}
      function Jump(S : PathStr) : Boolean;
        {-jump (GOTO) to label S}
      function GoSub(S : PathStr) : Boolean;
        {-jump to a label with provision for returning later}
      function Return : Boolean;
        {-return from a GOSUB}

      {...private methods}
      procedure NextActive;
      function FindLabel(S : PathStr) : PLine;
    end;


implementation

  procedure CleanCmts(var S : String);
  {-removes trailing comments from a line}
  var
    B : Byte;
  begin
    B := Length(S);
    while B > 0 do begin
      {exit if we've received a quote char}
      if (S[b] = '"') or (S[b] = #39) then
        exit;
      {if we've found the comment marker, remove the rest of the line and go}
      if (S[b] = CommentChar) then begin
        S[0] := Chr(B-1);
        S := Trim(S);
        exit;
      end;
      Dec(B);
    end;
  end;

{--- Script line node methods ---}

  constructor SLine.Init(S : String);
  begin
    if not DoubleListNode.Init then Fail;
    LP := PStr(StringToHeap(S));
    if LP = nil then Fail;
  end;

  destructor SLine.Done;
  begin
    DisposeString(Pointer(LP));
  end;

{--- ScriptMgr methods ---}

  constructor ScriptMgr.Init;
  begin
    if not DoubleList.Init then Fail;

    {init our internal vars}
    CurLevel := 0;
    CurP := nil;
    Running := False;
  end;

  destructor ScriptMgr.Done;
  begin
    DoubleList.Done;
  end;

  function ScriptMgr.ProcessLine(S : String) : Boolean;
  {-method to actually process the script line.  Returns false to abort script.}
  { *MUST BE OVERRIDDEN*}
  begin
    RunError(211);
  end;

  procedure ScriptMgr.PrepareLine(var S : String);
  {-perform pre-processing on line before adding it to the list.  Allows}
  { comments removal, etc.}
  begin
    S := Trim(S);
    CleanCmts(S);
  end;

  function ScriptMgr.LoadScript(FN : PathStr) : Boolean;
  {-load a script into our manager.  Returns false on error}
  label
    Breakout;
  var
    F : Text;
    S : String;
    P : PLine;
  begin
    {assume failure}
    LoadScript := False;

    Assign(F, FN);
    Reset(F);
    if IOResult <> 0 then exit;

    {create a dummy label to start the script}
    New(P, Init(':HEAD_OF_SCRIPT'));
    if P = nil then goto Breakout;
    Append(P);

    {read in the file}
    while not EOF(F) do begin
      ReadLn(F, S);
      if IOResult <> 0 then goto Breakout;

      {pre-process line}
      PrepareLine(S);

      {make sure it's a valid line}
      if (S <> '') then begin
        {if this is a label line, upcase it for later}
        if S[1] = ':' then
          S := StUpcase(S);

        {add it to the list}
        New(P, Init(S));
        if P = nil then goto Breakout;
        Append(P);
      end;
    end;

    {script loaded, initialize the current-line pointer}
    CurP := Pline(Head);
    LoadScript := True;

Breakout:
    Close(F);
    if IOResult = 0 then ;
  end;

  function ScriptMgr.LoadSubScript(FN : PathStr) : Boolean;
  {-Loads a secondary script onto the end of the first and GOSUBS to it}
  label
    Breakout;
  var
    F : Text;
    S : String;
    P, Q : PLine;
  begin
    LoadSubScript := False;
    {if we're maxed on GOSUB levels, fail}
    if CurLevel = 255 then exit;

    {generate a label using the file's name}
    S := JustFileName(FN);
    S := StUpCase(S);
    S := ':' + S;

    {see if said label is already in file...}
    P := FindLabel(S);
    if P <> nil then begin
      {this secondary script is already loaded, just jump to it}
      Inc(CurLevel);
      CurP^.Level := CurLevel;
      CurP := P;
      LoadSubScript := True;
      exit;
    end;

    Assign(F, FN);
    Reset(F);
    if IOResult <> 0 then exit;

    {add the new label to the list}
    New(P, Init(S));
    if P = nil then goto Breakout;
    Append(P);

    {load the rest of the script}
    while not EOF(F) do begin
      ReadLn(F, S);
      if IOResult <> 0 then goto Breakout;

      {pre-process line}
      PrepareLine(S);

      if (S <> '') then begin
        {if a label, upcase for later}
        if S[1] = ':' then
          S := StUpcase(S);

        {add to the list}
        New(Q, Init(S));
        if Q = nil then goto Breakout;
        Append(Q);
      end;
    end;

    {load was successful, GOSUB to the new script}
    Inc(CurLevel);
    CurP^.Level := CurLevel;
    CurP := P;
    LoadSubScript := True;

Breakout:
    Close(F);
    if IOResult = 0 then ;
  end;

  procedure ScriptMgr.NextActive;
  {-sets CurP to the next non-label line in the script}
  begin
    CurP := PLine(Next(CurP));
    {skip label lines}
    while (CurP <> nil) and (CurP^.LP^[1] = ':') do
      CurP := PLine(Next(CurP));
  end;

  function ScriptMgr.FindLabel(S : PathStr) : PLine;
  {-find the requested label; return line pointer or nil if not found}
  var
    P : PLine;
  begin
    FindLabel := nil;

    {make sure passed label is in proper format}
    S := StUpcase(S);
    if S[1] <> ':' then
      S := ':' + S;

    {scan the list looking for our matching label}
    P := PLine(Head);
    while P <> nil do begin
      if P^.LP^ = S then begin
        {found it!}
        FindLabel := P;
        exit;
      end;
      P := PLine(Next(P));
    end;
  end;


  function ScriptMgr.Jump(S : PathStr) : Boolean;
  {-jump (GOTO) to label S}
  var
    P : PLine;
  begin
    Jump := False;

    P := FindLabel(S);
    if P <> nil then begin
      {found it, set our vars}
      Jump := True;
      CurP := P;
    end;
  end;

  function ScriptMgr.GoSub(S : PathStr) : Boolean;
  var
    P : PLine;
  begin
    GoSub := False;

    {make sure we have a return marker}
    if CurLevel = 255 then exit;

    P := FindLabel(S);
    if P <> nil then begin
      {found it, set our vars}
      Inc(CurLevel);
      CurP^.Level := CurLevel;
      CurP := P;
      GoSub := True;
    end;
  end;

  function ScriptMgr.Return : Boolean;
  {-return from a GOSUB}
  var
    P : PLine;
  begin
    Return := False;

    {make sure we've got somewhere to return to}
    if CurLevel = 0 then exit;

    {look for our return point}
    P := PLine(Head);
    while P <> nil do begin
      if P^.Level = CurLevel then begin
        {found it; clean up nessessary vars and exit}
        Dec(CurLevel);
        P^.Level := 0;
        CurP := P;
        Return := True;
        exit;
      end;
      P := PLine(Next(P));
    end;
  end;

  procedure ScriptMgr.Process;
  {-run the script}
  begin
    {set flag noting script is now running}
    Running := True;

    while CurP <> nil do begin
      {get the next active line}
      NextActive;
      if CurP <> nil then
        {process it}
        if not ProcessLine(CurP^.LP^) then
          CurP := nil;
    end;

    Running := False;
  end;

end.