DP Tool Club 12/CD_ASCQ_12_0294.iso/maj/535/readscpt.pas

Pascal/Delphi Source File | 1994-01-02 | 17KB | 688 lines

{$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}

Unit ReadScpt;

Interface

uses Dos, Objects;

const
  MaxParam = 6;   {number of extra parameters}
Type
  {various types of controls which may be found in script file. -1 indicates
   end}
  RecType = (Dlg, Button, SText, CText, InputL, Labl, Histry, ILong, CheckB,
             RadioB, MultiCB, ListB, Memo, ScrollB);
  {various types of validators for TInputLine}
  ValType = (Picture, Range, Filter, StringLookup);

  BlockType = record   {all controls have this standard data block}
    BaseObj,            {like TInputLine}
    Obj : PString;      {like PInputLine or PMyInputLine}
    X1, Y1, X2, Y2,     {the TRect}
    DefOptns, Optns,    {default and actual options for control}
    DefEvMsk, EvMsk,    {default and actual eventmask for control}
    HCtx,               {HelpCtx value}
    Grow : integer;     {GrowMode value}
    Param : array[1..MaxParam] of PString;    {possible the extra parameters}
    HelpCtxSym,         {like hcNoContext}
    FieldName,          {field name you chose for data record}
    VarName : PString;  {variable name you chose or 'Control'}
    end;

  ScriptRec = record  {the variant record for the various controls}
    MainBlock : BlockType;  {the fixed part for all controls}
    case Kind: RecType of
      Dlg:  (Palette, WinFlags : word;    {the dialog itself}
             DlgFuncName,        {like MakeDialog}
             KeyString,          {ID string for resource}
             Title : PString;);  {dialog title}
      Button:
            (CommandName,           {like cmOK}
             ButtonText : PString;  {like O~k~}
             CommandValue,          {word value for Command}
             Flags : word;);        {flags}
      SText, CText:               {static and colored text}
            (Attrib : word;
             Text : PString;);
      InputL:
            (StringLeng : word;     {AMaxLen parameter}
             ValPtrName : PString;  {like PPXPictureString}
             case ValKind : ValType of    {ValKind = -1 if no validator}
               Picture:
                  (AutoFill : Byte;
                   PictureString : PString;);
               Range:
                  (LowLim, UpLim : LongInt;
                   Transfer : word;);    {non-zero if voTransfer bit set}
               StringLookUp:
                  (List : PString;);
               Filter:
                  (CharSet : PString;     {like "['a'..'z', '0'..'9']" }
                   {following represents the actual character set}
                   ActualCharSet : array[0..7] of LongInt;
                  );
             );
      ILong:
            (LongLabelText : PString; {text of the label--not used in Pascal}
             LongStrLeng : word;      {AMaxlen parameter}
             LLim, ULim : LongInt;
             ILOptions : word;);
      LabL: (LabelText,
             LinkName : PString;);    {variable name of control to which
                                       label is linked, often just 'Control'}
      Histry:
            (HistoryID : word;
             HistoryLink : PString;); {variable name of control to which
                                       label is linked, often just 'Control'}

      CheckB, RadioB, MultiCB:
            (Items : word;         {number of labels}
             Mask : LongInt;
             LabelColl : PStringCollection;  {collection of labels}
             MCBFlags : word;      {multi checkbox flags}
             SelRange : byte;      {multi checkbox SelRange}
             States : PString;);   {multi checkbox States}
      ListB:
            (Columns : word;
             ScrollBar : PString;);   {variable name of scrollbar}
      Memo: (TextFieldName : PString; {the second DataRec fieldname required by TMemo}
             BufSize : word;          {size of buffer}
             VScroll, HScroll : PString;);   {variable name of scrollbars}
    end;
  PScriptRec = ^ScriptRec;

  BitFunction = function(W : word): string;

var
  P, Dialog : PScriptRec;
  ScriptColl : PCollection;
  Present : array[Dlg..ScrollB] of boolean; {which types are present}

const
  ValidatorPresent : boolean = False;

procedure ChkIOerror(S : string);
{main script reading procedure}
procedure ReadScriptFile(FName : string);
{given a byte, word, longint, return the string hex equivalent}
function Hex2(B : Byte) : String;
function Hex4(W : word) : string;
function Hex8(L : LongInt) : string;
{compare two strings without regard to case}
function SameString(const S1, S2 : String) : Boolean;

{if the  filename has no extension, add the default extension}
function DefaultExt(const FName, DefExt : string) : string;

{functions use by OptionStr}
function GetWinFlagWords(W : word): string;
function GetEventWords(W : word): string;
function GetOptionWords(W : word): string;

{given default and actual options (or eventmask), come up with a source
 code phrase something like 'or ofFramed and not ofSelectable'.   Func is
 a function appropriate to the type of bits being looked at.
 It's known that Actual and Default are not equal on entry}
function OptionStr(Actual, Default : word; Func : BitFunction): string;

Implementation

Const
  VersionID = 'SCRIPT1';
  Tab = #9;

type
  PairType = array[0..1] of Char;   {reads two characters at once}

var
  Spair : PairType;
  LCh : Char absolute SPair;  {same address as SPair so LCh = Spair[0]}
  Chi, LineNo : integer;
  St : String;
  Inf : Text;
  L : LongInt;

function GetWinFlagWords(W : word): string;
const
  FlagArray : array[0..3] of String[7] =
       ('wfMove', 'wfGrow', 'wfClose', 'wfZoom');
var
  S : string;
  I : integer;
begin
S := '';
for I := 0 to 3 do
  begin
  if (W and 1 = 1) then
    S := S+FlagArray[I] + ' or ';
  W := W shr 1;
  end;
if Length(S) > 4 then Dec(S[0], 4);  {remove last ' or '}
GetWinFlagWords := S;
end;

function GetEventWords(W : word): string;
const
  FlagArray : array[0..15] of String[11] =
       ('evMouseDown', 'evMouseUp', 'evMouseMove', 'evMouseAuto',
        'evKeyDown', '$20', '$40', '$80', 'evCommand', 'evBroadcast',
        '$400', '$800', '$1000', '$2000', '$4000', '$8000');
var
  S : string;
  I : integer;
begin
S := '';
for I := 0 to 15 do
  begin
  if (W and 1 = 1) and (FlagArray[I] <> '') then
    S := S+FlagArray[I] + ' or ';
  W := W shr 1;
  end;
if Length(S) > 4 then Dec(S[0], 4);  {remove last ' or '}
GetEventWords := S;
end;

function GetOptionWords(W : word): string;
const
  FlagArray : array[0..15] of String[13] =
       ('ofSelectable', 'ofTopSelect', 'ofFirstClick', 'ofFramed',
        'ofPreProcess', 'ofPostProcess', 'ofBuffered', 'ofTileable',
        'ofCenterX', 'ofCenterY', 'ofValidate', '$800', 'ofVersion20',
        '$2000', '$4000', 'ofShoehorn');
var
  S : string;
  I : integer;
begin
S := '';
for I := 0 to 15 do
  begin
  if (W and 1 = 1) and (FlagArray[I] <> '') then
    S := S+FlagArray[I] + ' or ';
  W := W shr 1;
  end;
if Length(S) > 4 then Dec(S[0], 4);  {remove last ' or '}
GetOptionWords := S;
end;

function BitCount(W : word): integer;  {number of set bits in W}
var
  I, Count : integer;
begin
Count := 0;
for I := 0 to 15 do
  begin
  if W and 1 = 1 then
    Inc(Count);
  W := W shr 1;
  end;
BitCount := Count;
end;

function OptionStr(Actual, Default : word; Func : BitFunction): string;
{given default and actual options (or eventmask), come up with a source
 code phrase something like 'or ofFramed and not ofSelectable'.   Func is
 a function appropriate to the type of bits being looked at.
 It's known that Actual and Default are not equal on entry}
var
  S : string;
  NOTs, ORs, Diff : word;
begin
Diff := Actual xor Default;  {the bits that are different}
if BitCount(Diff) > 4 then
  begin   {this is too complex--output hex number}
  OptionStr := '$'+Hex4(Actual)+';';
  Exit;
  end;
NOTs := Diff and Default;  {the bits not in default}
ORs := Diff and Actual;    {the extra bits in actual}
S := '';
if NOTs <> 0 then
  if BitCount(NOTs) = 1 then
    S := ' and not ' + Func(NOTs)
  else
    S := ' and not(' + Func(NOTs) + ')';
if ORs <> 0 then
  S := S + ' or ' + Func(ORs);
OptionStr := S + ';';
end;

function DefaultExt(const FName, DefExt : string) : string;
{if no extension, add DefExt (which must contain the '.')}
var
  Dir : PathStr;
  Name : NameStr;
  Ext : ExtStr;
begin
FSplit(FName, Dir, Name, Ext);
if Ext = '' then Ext := DefExt;
DefaultExt := Dir+Name+Ext;
end;

function SameString(const S1, S2 : String) : Boolean;
var
  I : Integer;
begin
SameString := False;
if S1[0] <> S2[0] then Exit;
for I := 1 to Length(S1) do
  if UpCase(S1[I]) <> UpCase(S2[I]) then Exit;
SameString := True;
end;

function Hex2(B : Byte) : String;
Const
  HexArray : array[0..15] of char = '0123456789ABCDEF';
begin
Hex2[0] := #2;
Hex2[1] := HexArray[B shr 4];
Hex2[2] := HexArray[B and $F];
end;

function Hex4(W : word) : string;
begin
Hex4 := Hex2(Hi(W)) + Hex2(Lo(W));
end;

function Hex8(L : LongInt) : string;
begin
Hex8 := Hex4(LongRec(L).Hi)+Hex4(LongRec(L).Lo);
end;

function MyNewStr(const S: String): PString;
{like NewStr but never returns a Nil pointer}
var
  P: PString;
begin
if S = '' then
  begin
  GetMem(P, 1);  {kind of silly, but saves a lot of testing here}
  P^[0] := #0;
  end
else P := NewStr(S);
MyNewStr := P;
end;

PROCEDURE Error(const S : String);  {handle file read errors}
Var
  X : Integer;
  NewS : String;
  Ch : char;

  function Spaces(N : integer) : String;
  var
    S : string;
    I : integer;
  begin
  S := '';
  for I := 1 to N do
    S := S+' ';
  Spaces := S;
  end;

begin
Dec(St[0]);   {remove the ^M added by GetCh}
WriteLn(St);
X := Chi-1;
if X < 1 then X := 1;
Str(LineNo, NewS);
NewS := 'Line ' + NewS + ' Error, ' + S;
if X > Length(NewS) then
  WriteLn(Spaces(X-Length(NewS)-1), NewS, '^')
else
  WriteLn(Spaces(X-1), '^', NewS);
Close(Inf);
Halt(1);
end;

{
-------------ChkIOerror}
Procedure ChkIOerror(S : string);
Var
  IOerr : Integer;
  S1 : string[20];
begin
IOerr := IOResult;
if IOerr <> 0 then
  begin
  if IOerr = 2 then Write('Can''t find '+S)
  else
    begin
    Str(IOerr, S1);
    Write('I/O Error ', S1, ' in file ', S);
    end;
  Halt(1);
  end;
end;

{
-------------GetCh}
PROCEDURE GetCh;
{Return next character in LCh, next two characters in SPair}
begin
if Chi > Length(St) then
  begin      {need to read a line}
  if not Eof(Inf) then
    begin
    ReadLn(Inf,St);
    Inc(LineNo);
    St:=St+^M;  {Add EOL}
    Chi := 1;
    end
  else
    Error('Unexpected end of file');
  end;
word(SPair) := MemW[DSeg : Ofs(St[Chi])];      {LCh same as SPair[0]}
Inc(Chi);
end;

{
-------------SkipWhiteSpace}
procedure SkipWhiteSpace;
begin
while (LCh in [' ', Tab, ^M]) do
  GetCh;
end;

function GetString : PString;   {read a quoted string and return pointer to
 result.  Never returns Nil}
var
  S : string;
begin
S := '';
SkipWhiteSpace;
if LCh <> '"' then
  Error('Quoted string expected');
GetCh;
while (LCh <> '"') or (SPair = '"+') do  {+ is continuation char}
  begin
  if SPair = '\"' then  {SPair has same address as LCh}
    begin
    S := S+'"';
    GetCh;        {use up the extra character}
    end
  else if SPair = '\\' then
    begin
    S := S + '\';
    GetCh;
    end
  else if SPair = '\n' then
    begin
    S := S + ^M;
    GetCh;
    end
  else if SPair = '"+' then
    begin
    GetCh;  {skip '"'}
    GetCh;  {skip '+'}
    SkipWhiteSpace;
    if LCh <> '"' then
      Error('Quoted string continuation expected');
    end
  else S := S+LCh;  {Normal case}
  GetCh;
  end;
GetCh;    {use up last "}
GetString := MyNewStr(S);  {GetString is never Nil}
end;

function GetNumber : LongInt;  {read a decimal number from script file}
var
  S : string[20];
  Code : integer;
  V : LongInt;
begin
S := '';
SkipWhiteSpace;
if LCh = '-' then
  begin
  S := '-';
  GetCh;
  end;
if not (LCh in ['0'..'9']) then
  Error('Number expected');
while LCh in ['0'..'9'] do
  begin
  S := S + LCh;
  GetCh;
  end;
Val(S, V, code);
if code <> 0 then
  Error('Numerical error');
GetNumber := V;
end;

procedure ReadLabel(P : PScriptRec);  {read variant part of label record}
begin
with P^ do
  begin
  LabelText := GetString;
  LinkName := GetString;
  end;
end;

procedure ReadStaticText(P : PScriptRec);
begin
with P^ do
  begin
  Attrib := GetNumber;
  Text := GetString;
  end;
end;

procedure ReadHistory(P : PScriptRec);
begin
with P^ do
  begin
  HistoryID := GetNumber;
  HistoryLink := GetString;
  end;
end;

procedure ReadInputLine(P : PScriptRec);
var
  I : integer;
begin
with P^ do
  begin
  StringLeng := GetNumber;
  ValKind:= ValType(GetNumber);
  ValPtrName := GetString;
  ValidatorPresent := ValidatorPresent or (ord(ValKind) <> -1);
  case ValKind of     {ValKind = -1 if no validator}
    Picture:
      begin
      AutoFill := GetNumber;
      PictureString := GetString;
      end;
    Range:
      begin
      LowLim := GetNumber;
      UpLim := GetNumber;
      Transfer := GetNumber;
      end;
    StringLookUp:
      List := GetString;
    Filter:
      begin
      Charset := GetString;
      for I := 0 to 7 do
        ActualCharSet[I] := GetNumber;
      end;
    end;
  end;
end;

procedure ReadInputLong(P : PScriptRec);
begin
with P^ do
  begin
  LongLabelText := GetString;
  LongStrLeng := GetNumber;
  LLim := GetNumber;
  ULim := GetNumber;
  ILOptions := GetNumber;
  end;
end;

procedure ReadListBox(P : PScriptRec);
begin
with P^ do
  begin
  Columns := GetNumber;
  ScrollBar := GetString;
  end;
end;

procedure ReadButton(P : PScriptRec);
begin
with P^ do
  begin
  CommandName := GetString;
  ButtonText := GetString;
  CommandValue := GetNumber;
  Flags := GetNumber;
  end;
end;

procedure ReadMemo(P : PScriptRec);
begin
with P^ do
  begin
  TextFieldName := GetString;
  BufSize := GetNumber;
  VScroll := GetString;
  HScroll := GetString;
  end;
end;

procedure ReadCheckRadio(P : PScriptRec);
var
  I : integer;
begin
with P^ do
  begin
  Items := GetNumber;
  Mask := GetNumber;
  if Items > 0 then
    begin
    New(LabelColl, Init(10,10));    {a collection of labels}
    for I := 0 to Items-1 do        {insert from 1st to last, don't sort}
      LabelColl^.AtInsert(I, GetString);
    end;
  if Kind = MultiCB then
    begin
    MCBFlags := GetNumber;
    SelRange := GetNumber;
    States := GetString;
    end;
  end;
end;

procedure ReadDialog(P : PScriptRec); {read the variant part of dialog record}
begin
with P^ do
  begin
  Palette := GetNumber;
  WinFlags := GetNumber;
  DlgFuncName := GetString;
  KeyString := GetString;
  Title := GetString;
  end;
end;

procedure ReadMainBlock(P : PScriptRec; ThisKind : RecType);
{read the non-variant part of the control's record}
var
  I : integer;
begin
with P^, MainBlock do
  begin
  Kind := ThisKind;
  BaseObj := GetString;
  Obj := GetString;
  X1 := GetNumber;
  Y1 := GetNumber;
  X2 := GetNumber;
  Y2 := GetNumber;
  DefOptns := GetNumber;
  Optns := GetNumber;
  DefEvMsk := GetNumber;
  EvMsk := GetNumber;
  HCtx := GetNumber;
  Grow := GetNumber;
  for I := 1 to MaxParam do
    Param[I] := GetString;
  HelpCtxSym := GetString;
  FieldName := GetString;
  VarName := GetString;
  end;
end;

Procedure ReadScriptFile(FName : string);
var
  ThisKind : RecType;
begin
FillChar(Present, Sizeof(Present), 0);
New(ScriptColl, Init(10,10));

{$I-}
Assign(Inf, FName);
Reset(Inf);
ChkIOError(FName);
{$I+}

ReadLn(Inf, St);
if St <> VersionID then
  begin
  WriteLn('File is not a valid script file');
  Close(Inf);
  Halt(1);
  end;
LineNo := 1;
St := '';  Chi := 999;  {get the reading started}
GetCh;
GetString;         {reserved--of no use here}
L := GetNumber;    {Field number--of no use here}

ThisKind := RecType(GetNumber);
if ThisKind <> Dlg then
  Error('First item is not TDialog type');
New(Dialog);            {'Dialog' will hold the dialog info}
ReadMainBlock(Dialog, ThisKind);
Present[Dlg] := True;
ReadDialog(Dialog);
SkipWhiteSpace;

ThisKind := RecType(GetNumber);   {find out what kind of control this is}
while (Ord(ThisKind) > 0) do  {-1 terminates}
  begin
  if not (ThisKind in [Button..ScrollB]) then
     Error('Unrecognized control type');
  Present[ThisKind] := True;
  New(P);
  ReadMainBlock(P, ThisKind);
  with P^ do
    begin
    case ThisKind of   {read the variant part of the control's record}
      Button : ReadButton(P);
      InputL : ReadInputLine(P);
      LabL : ReadLabel(P);
      Histry : ReadHistory(P);
      ILong : ReadInputLong(P);
      CheckB, RadioB, MultiCB :
              ReadCheckRadio(P);
      ListB: ReadListBox(P);
      ScrollB :;   {already completely read}
      Memo: ReadMemo(P);
      SText, CText : ReadStaticText(P);
      end;
    ScriptColl^.Insert(P);  {insert in the collection of controls}
    SkipWhiteSpace;
    end;
  ThisKind := RecType(GetNumber);
  end;

Close(Inf);
end;

end.