console.pas

一个不出名的GBA模拟器

//////////////////////////////////////////////////////////////////////
//                                                                  //
// console.pas: Console and scripting system                        //
//   Manages the console, log, and configuration managment          //
//                                                                  //
// The contents of this file are subject to the Bottled Light       //
// Public License Version 1.0 (the "License"); you may not use this //
// file except in compliance with the License. You may obtain a     //
// copy of the License at http://www.bottledlight.com/BLPL/         //
//                                                                  //
// Software distributed under the License is distributed on an      //
// "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or   //
// implied. See the License for the specific language governing     //
// rights and limitations under the License.                        //
//                                                                  //
// The Original Code is the Mappy VM User Interface, released       //
// April 1st, 2003. The Initial Developer of the Original Code is   //
// Bottled Light, Inc. Portions created by Bottled Light, Inc. are  //
// Copyright (C) 2001-2003 Bottled Light, Inc. All Rights Reserved. //
//                                                                  //
// Author(s):                                                       //
//   Michael Noland (joat), [e-mail]                //
//                                                                  //
// Changelog:                                                       //
//   1.0: First public release (April 1st, 2003)                    //
//                                                                  //
// Notes:                                                           //
//   FontToString and BooleanToString should probably be moved      //
//   somewhere else.                                                //
//                                                                  //
//////////////////////////////////////////////////////////////////////

//////////////////////////////////////////////////////////////////////
unit console; ////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////

//////////////////////////////////////////////////////////////////////
interface ////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////

uses
  Classes, Graphics, SysUtils, Math;

//////////////////////////////////////////////////////////////////////

type
  TConsoleCallback = function (params: string): string;
  TLogCallback = procedure (newLines: integer) of object;

//////////////////////////////////////////////////////////////////////

// logWrite prints a string to the log/console, you must provide
// line returns yourself
procedure logWrite(st: string);

// logWriteLn prints a string to the console and appends a line return
procedure logWriteLn(st: string);

// logAddCommand adds a function to the console namespace.  A console
// command or callback takes its parameters in the form of a string, and
// returns status information or an error code if desired.  For any static
// valued function (one prefixed with a $, to be saved on program exit),
// an input parameter of '' should return a string that can be passed in
// at a later date as a parameter to restore the state, i.e. the following
// should be an identity function:
//    logSetValue(funcName, logGetValue(funcName))
// As logGetValue with a parameter of type function returns the value that
// the function returns when passed ''
procedure logAddCommand(name: string; callback: TConsoleCallback); overload;
procedure logAddCommand(name: string; callback: TConsoleCallback; help: string); overload;
procedure logAddCommand(name: string; callback: TConsoleCallback; value, help: string); overload;

// Adds an integer|string|boolean
procedure logAddInteger(name: string; var d: integer); overload;
procedure logAddInteger(name: string; var d: integer; help: string); overload;
procedure logAddInteger(name: string; var d: integer; value, help: string); overload;
procedure logAddString(name: string; var d: string); overload;
procedure logAddString(name: string; var d: string; help: string); overload;
procedure logAddString(name: string; var d: string; value, help: string); overload;
procedure logAddBoolean(name: string; var d: boolean); overload;
procedure logAddBoolean(name: string; var d: boolean; help: string); overload;
procedure logAddBoolean(name: string; var d: boolean; value, help: string); overload;

// Get the value of a console variable, or the result of a console function
// called with no parameters
function logGetValue(name: string): string; overload;
function logGetValue(index: integer): string; overload;

// Set a console varable's value, or call a console function with a parameter
// list of value
procedure logSetValue(name, value: string); overload;
procedure logSetValue(index: integer; value: string); overload;

// Process a command as if it were typed into the console
procedure logProcessCommand(st: string);
procedure logProcessCommandSilent(st: string);

// Set the callback function for a log observer
procedure logSetCallback(callback: TLogCallback);

// Retrieve a range of entries from the log
procedure logGetEntries(last, count: integer; list: TStrings);

// Returns the number of entries in the log
function logNumEntries: integer;

// Returns true if there are new entries in the log since the
// last time logGetEntries was called, otherwise false.
function logBeenUpdated: boolean;

// Loads and executes a sequence of commands on lines in the passed
// in file or string list
procedure logExecuteScript(filename: string); overload;
procedure logExecuteScript(script: TStringList); overload;

// Saves any console variables whose names are prefixed with a '$',
// and the null result (result returned when a function is called
// with no parameters) for any console functions prexied with '$'
// to a file in a format suitable for loading via logExecuteScript
procedure logSaveSettings(filename: string); overload;
procedure logSaveSettings(script: TStringList); overload;

procedure logSaveLog(filename: string);
procedure logClear;

//////////////////////////////////////////////////////////////////////

procedure StringToFont(sFont: string; Font: TFont);
function FontToString(Font: TFont): string;

function BooleanToString(value: boolean): string;
function StringToBoolean(value: string): boolean;

function CutLeft(var st: string): string;
function ThwackString(ch: char; var st: string): string;
function CutAnyLeft(var st: string; ch: char): string;

//////////////////////////////////////////////////////////////////////
implementation ///////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////

//uses
//  dbgExpressions;

//////////////////////////////////////////////////////////////////////

type
  TConsoleType = (ctFunc, ctInteger, ctString, ctBoolean);

  TConsoleEntry = class
    myType: TConsoleType;
    myData: pointer;
    help: string;
    constructor Create(typ: TConsoleType; data: pointer); overload;
    constructor Create(typ: TConsoleType; data: pointer; helpInfo: string); overload;
    procedure SetValue(st: string);
    function GetHelp: string;
    function GetValue: string;
  end;

//////////////////////////////////////////////////////////////////////

const
  cTypeNames: array[TConsoleType] of string =
    ('function', 'integer', 'string', 'boolean');

//////////////////////////////////////////////////////////////////////

var
  currentString: string;
  log: TStringList;
  maxLogSize: integer;
  cvars: TStringList;
  logViewer: TLogCallback;
  beenUpdated: boolean;

//////////////////////////////////////////////////////////////////////

const
  csfsBold = '|Bold';
  csfsItalic = '|Italic';
  csfsUnderline = '|Underline';
  csfsStrikeout = '|Strikeout';

//////////////////////////////////////////////////////////////////////

function CutLeft(var st: string): string;
var
  i: integer;
begin
  i := Pos(' ', st);
  if i > 0 then begin
    Result := Copy(st, 1, i-1);
    Delete(st, 1, i);
  end else begin
    Result := st;
    st := '';
  end;
end;

//////////////////////////////////////////////////////////////////////

function ThwackString(ch: char; var st: string): string;
var
  i: integer;
begin
  i := Pos(ch, st);
  if i > 0 then begin
    Result := Copy(st, i+1, Length(st)-i);
    Delete(st, i, Length(st)-i+1);
  end else
    Result := '';
end;

//////////////////////////////////////////////////////////////////////

function CutAnyLeft(var st: string; ch: char): string;
var
  i: integer;
begin
  i := Pos(ch, st);
  if i > 0 then begin
    Result := Copy(st, 1, i-1);
    Delete(st, 1, i);
  end else begin
    Result := st;
    st := '';
  end;
end;

//////////////////////////////////////////////////////////////////////

procedure StringToFont(sFont: string; Font: TFont);
var
  p: integer;
  sStyle: string;
begin
  with Font do begin
    // get font name
    p := Pos( ',', sFont );
    Name := Copy(sFont, 2, p-3);
    Delete(sFont, 1, p);

    // get font size
    p := Pos(',', sFont);
    Size := StrToInt(Copy(sFont, 2, p-2));
    Delete(sFont, 1, p);

    // get font style
    p := Pos( ',', sFont);
    sStyle := '|' + Copy(sFont, 3, p-4);
    Delete(sFont, 1, p);

    // get font color
    Color := StringToColor(Copy(sFont, 3, Length( sFont ) - 3));

    Style := [];
    if Pos(csfsBold, sStyle) > 0 then Style := Style + [fsBold];
    if Pos(csfsItalic, sStyle) > 0 then Style := Style + [fsItalic];
    if Pos(csfsUnderline, sStyle) > 0 then Style := Style + [fsUnderline];
    if Pos(csfsStrikeout, sStyle) > 0 then Style := Style + [fsStrikeout];
  end;
end;

//////////////////////////////////////////////////////////////////////

function FontToString(Font: TFont): string;
var
  sStyle: string;
begin
  with Font do begin
    sStyle := '';

    if fsBold in Style then sStyle := sStyle + csfsBold;
    if fsItalic in Style then sStyle := sStyle + csfsItalic;
    if fsUnderline in Style then sStyle := sStyle + csfsUnderline;
    if fsStrikeout in Style then sStyle := sStyle + csfsStrikeout;

    if (Length(sStyle) > 0) and (sStyle[1] = '|') then
      sStyle := Copy(sStyle, 2, Length(sStyle) - 1);

    Result := Format('"%s", %d, [%s], [%s]', [Name, Size, sStyle, ColorToString(Color)]);
  end;
end;

//////////////////////////////////////////////////////////////////////

function BooleanToString(value: boolean): string;
begin
  if value then Result := 'true' else Result := 'false';
end;

//////////////////////////////////////////////////////////////////////

function StringToBoolean(value: string): boolean;
begin
  value := Uppercase(value);
  if value = 'TRUE' then
    Result := true
  else if value = 'FALSE' then
    Result := false
  else
    Result := StrToIntDef(value, 0) <> 0;
end;

//////////////////////////////////////////////////////////////////////

function CFuncSetValue(params: string): string;
begin
  // Just an alias for a normal set command only its silent
  logProcessCommandSilent(params);
  Result := '';
end;

//////////////////////////////////////////////////////////////////////

function CFuncList(params: string): string;
var
  i: integer;
begin
  // List all the entries in the namespace
  for i := 0 to cvars.Count - 1 do
    logWriteLn('  ' + cvars.strings[i] + ': ' + cTypeNames[TConsoleEntry(cvars.objects[i]).myType]);
  Result := '';
end;

//////////////////////////////////////////////////////////////////////

function CFuncHelp(params: string): string;
var
  st: string;
  index: integer;
begin
  // Load the help
  if params = '' then params := 'help';
  index := cvars.IndexOf(lowercase(params));
  if index > -1 then
    st := TConsoleEntry(cvars.Objects[index]).help
  else
    st := '';

  // Display the help
  if st <> '' then
    logWriteLn(params + ': ' + st)
  else
    logWriteLn('No help entry found for ' + params);

  // Return the help, for whatever reason
  Result := '';
end;

//////////////////////////////////////////////////////////////////////

function CFuncClear(params: string): string;
begin
  logClear;
  if Assigned(logViewer) then logViewer(0);
end;

//////////////////////////////////////////////////////////////////////

function FirstToken(st: string): string;
var
  i: integer;
begin
  i := Pos(' ', st);
  if i = 0 then i := Length(st)+1;
  Result := Copy(st, 1, i-1);
  beenUpdated := true;
end;

//////////////////////////////////////////////////////////////////////

procedure logWriteLn(st: string);
begin
  log.Add(currentString + st);
{  while log.Count > maxLogSize do begin
    log.Delete(0);
    log.Delete(0);
    log.Delete(0);
    log.Delete(0);
    log.Delete(0);
    log.Delete(0);
  end;}
  currentString := '';
  if Assigned(logViewer) then logViewer(1);
  beenUpdated := true;
end;

//////////////////////////////////////////////////////////////////////

procedure logWrite(st: string);
var
  p: integer;
begin
  p := Pos(#10, st);
  while p > 0 do begin
    logWriteLn(Copy(st, 1, p-1));
    Delete(st, 1, p);
    p := Pos(#10, st);
  end;
  currentString := currentString + st;
  if Assigned(logViewer) then logViewer(0);
end;

//////////////////////////////////////////////////////////////////////

procedure logAddCommand(name: string; callback: TConsoleCallback);
begin
  cvars.AddObject(Lowercase(name), TConsoleEntry.Create(ctFunc, @callback));
end;

//////////////////////////////////////////////////////////////////////

procedure logAddCommand(name: string; callback: TConsoleCallback; help: string);
begin
  cvars.AddObject(Lowercase(name), TConsoleEntry.Create(ctFunc, @callback, help));
end;

//////////////////////////////////////////////////////////////////////

procedure logAddCommand(name: string; callback: TConsoleCallback; value, help: string);
begin
  logSetValue(cvars.AddObject(Lowercase(name), TConsoleEntry.Create(ctFunc, @callback, help)), value);
end;

//////////////////////////////////////////////////////////////////////