passrc2.pas

BORLAND公司C语言对话框开发程序

  end;
end;

procedure WriteHistory(P : PScriptRec);
begin
with P^, MainBlock do
  begin
  Write(OutF, '  ');
  RDotAssign(P);
  WriteLn(OutF, '  Insert(New(PHistory, Init(R, PInputline(',
                    HistoryLink^, '), ', HistoryID, ')));');
  end;
end;

procedure WriteStaticText(P : PScriptRec);
  procedure DoAtText;
  var
    S : string;
    I : integer;
  begin
  S := P^.Text^;
  I := Pos(^C, S);
  while I > 0 do
    begin
    Delete(S, I, 1);  {remove ^C's}
    I := Pos(^C, S);
    end;
  Delete(S, 1, 1);   {remove '@'}
  I := Pos(^M, S);
  while I > 0 do
    begin
    Delete(S, I, 1);  {remove ^M's}
    I := Pos(^M, S);
    end;
  Write(OutF, S);
  end;

  procedure DoText;  {split Text into short lines if it is long}
                     {convert single quotes to double}
  var
    I, Count, TextLeng : Integer;
    Ch : char;
    S : string[20];
  begin
  Write(OutF, '''');
  Count := 38;
  with P^ do
    begin
    I := 1;
    TextLeng := Length(Text^);
    while I <= TextLeng do
      begin
      Ch := Text^[I];
      if Ch = ^M then
         begin
         if I >= TextLeng then
            S := ''    {on the end}
         else S := '''^M+'^M^J'     ''';
         Count := 0;
         end
      else if Ch = '''' then
         S := ''''''    {one quote to two}
      else S := Ch;
      Write(OutF, S);
      Inc(Count, Length(S));
      if (Count >= 75) and (I < TextLeng) then
        begin
        Write(OutF, '''+'^M^J'     ''');
        Count := 5;
        end;
      Inc(I);
      end;
    end;
  Write(OutF, '''');
  end;

begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  Write(OutF, VarName^, ' := New('+Obj^+', Init(R, ');
  if (Length(Text^) > 1) and ((Text^[1] = '@')
         or (Text^[2] = '@')) then    {could be ^C'@'}
    DoAtText
  else
    DoText;
  if Kind = SText then
    WriteLn(OutF, '));')
  else
    WriteLn(OutF, ', $', Hex2(Byte(Attrib)), '));');
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');
  end;
end;

procedure WriteLabel(P : PScriptRec);
begin
with P^, MainBlock do
  begin
  Write(OutF, '  ');
  RDotAssign(P);
  WriteLn(OutF, '  Insert(New('+Obj^+', Init(R, '+
          Quoted(LabelText^)+', ', LinkName^, ')));' );
  end;
end;

procedure FormDialog;

  procedure DoControls(P : PScriptRec); far;
  begin
  case P^.Kind of
    Button: WriteButton(P);
    InputL: WriteInputLine(P);
    Labl: WriteLabel(P);
    Histry: WriteHistory(P);
    ILong: WriteInputLong(P);
    CheckB, RadioB, MultiCB:
           WriteCheckRadio(P);
    ListB: WriteListBox(P);
    ScrollB: WriteScrollBar(P);
    Memo:  WriteMemo(P);
    CText, SText: WriteStaticText(P);
    end;
  WriteLn(OutF);
  end;

begin
with Dialog^, MainBlock do
  begin
  RDotAssign(Dialog);
  WriteLn(Outf, 'inherited Init(R, ', Quoted(Title^), ');');

  if DefOptns <> Optns then
    begin
    Write(Outf, 'Options := ');
    S := OptionStr(Optns, DefOptns, GetOptionWords);
    if S[1] = '$' then
      WriteLn(OutF, S)
    else WriteLn(OutF, 'Options', S);
    end;
  if DefEvMsk <> EvMsk then
    begin
    Write(Outf, 'EventMask := ');
    S := OptionStr(EvMsk, DefEvMsk, GetEventWords);
    if S[1] = '$' then
      WriteLn(OutF, S)
    else WriteLn(OutF, 'EventMask', S);
    end;

  WriteHelpCtx(Nil, HelpCtxSym^, HCtx);
  if Palette <> dpGrayDialog then
    begin
    if Palette = dpBlueDialog then S := 'dpBlueDialog'
      else S := 'dpCyanDialog';
    WriteLn(Outf, 'Palette := ', S, ';');
    end;

  if WinFlags <> 5 then
    WriteLn(Outf, 'Flags := Flags',
                  OptionStr(WinFlags, 5, GetWinFlagWords));
  WriteLn(OutF);

  ScriptColl^.ForEach(@DoControls);
  end;
end;

procedure DoTheVars;
var
  DidSomething : boolean;

  procedure DoVars(P : PScriptRec); far;
  var
    Control1 : boolean;
  begin
  with P^, MainBlock do
    begin
    Control1 := SameString(VarName^, 'Control1');
    NeedControl1 := NeedControl1 or Control1;  {see if Control1 var will be needed}
    if (VarName^ <> '') and not SameString(VarName^, 'Control')
        and not Control1 then
      begin
      WriteLn(OutF, '    ', VarName^, ' : ', Obj^, ';');
      DidSomething := True;
      end;
    end;
  end;
begin
DidSomething := False;
ScriptColl^.ForEach(@DoVars);
if DidSomething then WriteLn(OutF);  {extra line}
end;

procedure SubViewPtr(Load : boolean);

  procedure DoVars(P : PScriptRec); far;
  begin
  with P^, MainBlock do
    if (VarName^ <> '') and not SameString(VarName^, 'Control')
            and not SameString(VarName^, 'Control1') then
        begin
        if Load then Write(OutF, 'GetSubViewPtr(S, ')
        else Write(OutF, 'PutSubViewPtr(S, ');
        WriteLn(OutF, VarName^, ');');
        end;
  end;
begin
ScriptColl^.ForEach(@DoVars);
end;

procedure DoDataRecord;
var
  First : boolean;

  procedure DoFields(P : PScriptRec); far;
  var
    S : string[15];
  begin
  with P^, MainBlock do
    if FieldName^ <> '' then
      begin
      if First then  {at least one fieldname to output}
        begin
        WriteLn(OutF, '  ', Dialog^.MainBlock.FieldName^, ' = record');
        First := False;
        end;
      Write(OutF, '    ', FieldName^);
      case Kind of
        CheckB, RadioB :
           Write(OutF, ' : Word;');
        MultiCB, ILong :
           Write(OutF, ' : LongInt;');
        InputL :
          begin
          if (ValKind = Range) and (Transfer <> 0) then
             Write(OutF, ' : LongInt;')
          else
            begin
            Str(StringLeng, S);
            Write(OutF, ' : String['+S+'];');
            end;
          end;
        ListB :
          Write(OutF, ' : TListBoxRec;');
        Memo :
          begin
          WriteLn(OutF, ' : Word;');
          Str(BufSize, S);
          Write(OutF, '    ', TextFieldName^, ' : Array[1..'+S+'] of Char;');
          end;
        end;
      WriteLn(OutF);
      end;
  end;

begin
with Dialog^, MainBlock do
  if FieldName^ <> '' then
    begin
    if Present[ListB] then  {make sure TListBoxRec is defined}
      WriteLn(OutF,
      '  TListBoxRec = record    {<-- omit if TListBoxRec is defined elsewhere}'^M^J+
      '    List: PCollection;'^M^J+
      '    Selection: Word;'^M^J+
      '  end;'^M^J);

    First := True;
    ScriptColl^.ForEach(@DoFields);
    if not First then    {if First still set, there is no data record}
      begin
      WriteLn(OutF, '    end;');
      WriteLn(OutF, '  P'+FieldName^, ' = ^', FieldName^, ';');
      end;
    end;
end;

function FindSkelDat: string;
{look for 'skel.dat' in the directory where this file was found}
var
  EXEName, Dir : PathStr;
  Ext : ExtStr;
  Name : NameStr;
begin
if Lo(DosVersion) >= 3 then EXEName := ParamStr(0)
else EXEName := FSearch('PASSRC2.EXE', GetEnv('PATH'));
FSplit(EXEName, Dir, Name, Ext);
if Dir[Length(Dir)] = '\' then Dec(Dir[0]);
FindSkelDat := FSearch('SKEL.DAT', Dir);
end;

function HeapFunc(Size : word) : integer; far;
begin
if Size > 0 then
  begin
  WriteLn('Out of memory');
  Halt(1);
  end;
end;

var
  I : Integer;
  Inf : Text;

begin
HeapError := @HeapFunc;

if ParamCount < 2 then
  begin
  WriteLn('Usage:  passrc2 <script filename> <source filename> [error filename]');
  Halt(1);
  end;
if ParamCount >= 3 then
  begin
  Assign(OutPut, ParamStr(3));   {the error file}
  ReWrite(Output);
  end;
{$I-}
Assign(Inf, FindSkelDat);    {find the data file, skel.dat}
Reset(Inf);
ChkIOError('skel.dat');

ReadScriptFile( DefaultExt (ParamStr(1), '.SCP'));  {ParamStr(1) is script file}

Assign(OutF, DefaultExt (ParamStr(2), '.PAS'));    {ParamStr(2) is output source file}
Rewrite(OutF);
ChkIOError(DefaultExt (ParamStr(2), '.PAS'));
{$I+}

while not Eof(Inf) do
  begin
  ReadLn(Inf, S);
  if S = '@ZZ0' then FormDialog
  else if S = '@ZZ1' then DoTheVars
  else if S = '@ZZ2' then DoDataRecord
  else if S = '@ZZ3' then SubViewPtr(True)
  else if S = '@ZZ4' then SubViewPtr(False)
  else
    begin
    I := Pos('@XX', S);
    while I > 0 do
      begin
      Subst(I);
      I := Pos('@XX', S);
      end;
    WriteLn(OutF, S)
    end;
  end;
Close(InF);
Close(OutF);
end.