home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / UTILS / DLGDS4 / PASSRC2.PAS < prev    next >
Pascal/Delphi Source File  |  1993-08-05  |  16KB  |  614 lines
  1. {Substitutions and fills in file, skel.dat
  2.   Area Fills
  3.   @ZZ0    Form the dialog in constructor
  4.   @ZZ1    Defined Control Names in Object Def.
  5.   @ZZ2    Data record def
  6.   @ZZ3    Load GetSubViewPtr
  7.   @ZZ4    Store PutSubViewPtr
  8.  
  9.   Substitutions
  10.   @XX0    Dialog's Pointer  (as  PMyDialog)
  11.   @XX1    Dialog's Symbol   (as  TMyDialog)
  12.   @XX2    Dialog's ancestor (usually TDialog)
  13.   @XX3    Dialog's registration TStreamRec (as RMyDialog)
  14.   @XX4    Unit name
  15.   @XX5    'Control1'
  16.   @XX6    uses clause items
  17.  
  18. }
  19. {$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
  20. {$M 16384,5000,655360}
  21.  
  22. Program PasSrc2;
  23.  
  24. uses Dos, Memory, Objects, Drivers, Views, Dialogs,
  25.      Editors, ColorTxt, InpLong, Validate, ReadScpt;
  26.  
  27. const
  28.   NeedControl1 : boolean = False;
  29. var
  30.   OutF : Text;
  31.   S : String;
  32.  
  33. PROCEDURE Subst(I : Integer);   {make a substitution for @XXn.  I is the
  34.   location of @XXn in S }
  35. var
  36.   N : Byte;
  37.   St : String;
  38.   Name : NameStr;
  39.   Ext : ExtStr;
  40. begin
  41. N := Ord(S[I+3]) - Ord('0');  {get the substitution number}
  42. Delete(S, I, 4);              {delete the @XXn }
  43. case N of
  44.   0 : Insert(Dialog^.MainBlock.Obj^, S, I);  {like PMyDialog}
  45.   1 : begin
  46.       St := Dialog^.MainBlock.Obj^;
  47.       if St[1] in ['P', 'p'] then Delete(St,1,1);
  48.       Insert('T', St, 1);
  49.       Insert(St, S, I);
  50.       end;
  51.   2 : Insert(Dialog^.MainBlock.BaseObj^, S, I);  {like TDialog}
  52.   3 : begin
  53.       St := Dialog^.MainBlock.Obj^;
  54.       if St[1] in ['P', 'p'] then Delete(St,1,1);
  55.       Insert('R', St, 1);
  56.       Insert(St, S, I);
  57.       end;
  58.   4 : begin   {unit name same as filename}
  59.       FSplit(ParamStr(2), St, Name, Ext);
  60.       Insert(Name, S, I);
  61.       end;
  62.   5 : if NeedControl1 then Insert(', Control1', S, I);
  63.   6 : begin
  64.       St := '';
  65.       if Present[CText] then St := ', ColorTxt';
  66.       if Present[ILong] then St := St+', InpLong';
  67.       if Present[Memo] then St := St+', Editors';
  68.       if ValidatorPresent then St := St+', Validate';
  69.       if St <> '' then Insert(St, S, I);
  70.       end;
  71.   end;
  72. end;
  73.  
  74. function Positn(Pat, Src : String; I : Integer) : Integer;
  75. {find the position of a substring in a string starting at the Ith char}
  76. var
  77.   N : Integer;
  78. begin
  79. if I < 1 then I := 1;
  80. Delete(Src, 1, I-1);
  81. N := Pos(Pat, Src);
  82. if N = 0 then Positn := 0
  83.   else Positn := N+I-1;
  84. end;
  85.  
  86. FUNCTION Quoted(S : string) : string;
  87. {Puts single quotes around a string and doubles any internal single quotes}
  88. var
  89.   I : Integer;
  90. begin
  91. I := Pos('''', S);
  92. while I > 0 do
  93.   begin
  94.   Insert('''', S, I);
  95.   I := Positn('''', S, I+2);
  96.   end;
  97. Insert('''', S, 1);
  98. Quoted := S+'''';
  99. end;
  100.  
  101. procedure RDotAssign(P : PScriptRec);
  102. begin
  103. with P^.MainBlock do
  104.   begin
  105.   WriteLn(Outf, 'R.Assign(', X1, ', ', Y1, ', ', X2,', ', Y2, ');');
  106.   end;
  107. end;
  108.  
  109. procedure DoOpEvent(P : PScriptRec; const Sym : string);
  110. begin
  111. with P^.MainBlock do
  112.   begin
  113.   if DefOptns <> Optns then
  114.     WriteLn(Outf, Sym, '^.Options := ', Sym, '^.Options',
  115.                   OptionStr(Optns, DefOptns, GetOptionWords));
  116.   if DefEvMsk <> EvMsk then
  117.     WriteLn(Outf, Sym, '^.EventMask := ', Sym, '^.EventMask',
  118.                   OptionStr(EvMsk, DefEvMsk, GetEventWords));
  119.   end;
  120. end;
  121.  
  122. PROCEDURE WriteHelpCtx(Rf : PString; H : String; Ctx : word);
  123. Const
  124.   NoContext : String[11] = 'hcNoContext';
  125. begin
  126. if (H = '') and (Ctx > 0) then
  127.    Str(Ctx, H);
  128. if (H <> '') and not SameString(H, NoContext) then
  129.   if Rf <> Nil then
  130.     WriteLn(OutF, Rf^, '^.HelpCtx := ', H, ';' )
  131.   else WriteLn(OutF, 'HelpCtx := ', H, ';' )
  132. end;
  133.  
  134. procedure WriteButton(P : PScriptRec);
  135. var
  136.   S : string[55];
  137.  
  138.   function FlagStr : string;
  139.   var
  140.     S : string[55];
  141.   begin
  142.   with P^ do
  143.     begin
  144.     S := '';
  145.     if Flags = 0 then S := 'bfNormal'
  146.     else
  147.       begin
  148.       if Flags and 1 <> 0 then S := 'bfDefault+';
  149.       if Flags and 2 <> 0 then S := S+'bfLeftJust+';
  150.       if Flags and 4 <> 0 then S := S+'bfBroadcast+';
  151.       if Flags and 8 <> 0 then S := S+'bfGrabFocus+';
  152.       Dec(S[0]);  {remove extra '+'}
  153.       end;
  154.     end;
  155.   FlagStr := S;
  156.   end;
  157.  
  158. begin
  159. with P^, MainBlock do
  160.   begin
  161.   RDotAssign(P);
  162.   if SameString(Obj^, 'POptionButton') then  {a special TOptionButton}
  163.     WriteLn(OutF, VarName^, ' := New(', Obj^, ', Init(R, ', Param[1]^,
  164.          ', '+Param[2]^+'));' )
  165.   else
  166.     begin   {regular button}
  167.     if CommandName^ <> '' then S := CommandName^
  168.       else Str(CommandValue, S);
  169.     Write(OutF, VarName^, ' := New(', Obj^, ', Init(R, ',
  170.          Quoted(ButtonText^), ', '+S+', ' );
  171.     WriteLn(OutF, FlagStr+'));' );
  172.     end;
  173.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  174.   DoOpEvent(P, VarName^);
  175.   WriteLn(OutF, 'Insert(', VarName^, ');');
  176.   end;
  177. end;
  178.  
  179. procedure WriteInputLong(P : PScriptRec);
  180. begin
  181. with P^, MainBlock do
  182.   begin
  183.   RDotAssign(P);
  184.   WriteLn(OutF,
  185.          VarName^, ' := New('+Obj^+', Init(R, ', LongStrLeng,
  186.          ', ', LLim, ', ', ULim,  ', ', ILOptions, '));' );
  187.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  188.   DoOpEvent(P, VarName^);
  189.   WriteLn(OutF, 'Insert(', VarName^, ');');
  190.   end;
  191. end;
  192.  
  193. procedure WriteInputLine(P : PScriptRec);
  194. var
  195.   S : string[15];
  196. begin
  197. with P^, MainBlock do
  198.   begin
  199.   RDotAssign(P);
  200.   WriteLn(OutF,
  201.          VarName^, ' := New('+Obj^+', Init(R, ', StringLeng, '));' );
  202.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  203.   DoOpEvent(P, VarName^);
  204.   WriteLn(OutF, 'Insert(', VarName^, ');');
  205.  
  206.   if ValKind in [Picture..StringLookup] then
  207.     begin
  208.     Write(OutF, '  ', Obj^+'('+VarName^+')^.Validator := New(', ValPtrName^,
  209.         ', Init(');
  210.     case ValKind of
  211.       Picture:
  212.          begin
  213.          if AutoFill <> 0 then S := 'True' else S := 'False';
  214.          WriteLn(OutF, Quoted(PictureString^), ', ', S, '));');
  215.          end;
  216.       Range:
  217.          begin
  218.          WriteLn(OutF, LowLim, ', ', UpLim, '));');
  219.          if Transfer <> 0 then
  220.            WriteLn(OutF, '  ',
  221.                Obj^+'('+VarName^+')^.Validator^.Options := voTransfer;');
  222.          end;
  223.       Filter:
  224.          WriteLn(OutF, CharSet^, '));');
  225.       StringLookup:
  226.          WriteLn(OutF, List^, '));');
  227.       end;
  228.     end;
  229.   end;
  230. end;
  231.  
  232. procedure WriteMemo(P : PScriptRec);
  233. begin
  234. with P^, MainBlock do
  235.   begin
  236.   RDotAssign(P);
  237.   Write(OutF,
  238.          VarName^, ' := New('+Obj^+', Init(R, ');
  239.   if HScroll^ <> '' then
  240.     Write(OutF, 'PScrollbar(Control1), ')
  241.   else Write(OutF, 'Nil, ' );
  242.   if VScroll^ <> '' then
  243.     Write(OutF, 'PScrollbar(Control), ')
  244.   else Write(OutF, 'Nil, ' );
  245.   WriteLn(OutF, 'Nil, ', BufSize, '));');
  246.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  247.   DoOpEvent(P, VarName^);
  248.   WriteLn(OutF, 'Insert(', VarName^, ');');
  249.   end;
  250. end;
  251.  
  252. procedure WriteListBox(P : PScriptRec);
  253. begin
  254. with P^, MainBlock do
  255.   begin
  256.   RDotAssign(P);
  257.   Write(OutF,
  258.          VarName^, ' := New('+Obj^+', Init(R, ', Columns);
  259.   if Scrollbar^ <> '' then
  260.     WriteLn(OutF, ', PScrollbar('+ScrollBar^+')));')
  261.   else WriteLn(OutF, ', Nil));' );
  262.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  263.   DoOpEvent(P, VarName^);
  264.   WriteLn(OutF, 'Insert(', VarName^, ');');
  265.   end;
  266. end;
  267.  
  268. procedure WriteScrollBar(P : PScriptRec);
  269. begin
  270. with P^, MainBlock do
  271.   begin
  272.   RDotAssign(P);
  273.   WriteLn(OutF,
  274.          VarName^, ' := New('+Obj^+', Init(R));');
  275.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  276.   DoOpEvent(P, VarName^);
  277.   WriteLn(OutF, 'Insert(', VarName^, ');');
  278.   end;
  279. end;
  280.  
  281. procedure WriteCheckRadio(P : PScriptRec);
  282. var
  283.   I : integer;
  284. begin
  285. with P^, MainBlock do
  286.   begin
  287.   RDotAssign(P);
  288.   Write(OutF,
  289.          VarName^, ' := New('+Obj^+', Init(R, ');
  290.   for I := 0 to Items-1 do
  291.     Write(OutF, ^M^J'  NewSItem(', Quoted(PString(LabelColl^.At(I))^), ',');
  292.   Write(OutF, ' Nil)');
  293.   for I := 1 to Items -1 do
  294.     Write(OutF, ')');
  295.   if Kind = MultiCB then
  296.     Write(OutF, ', ', SelRange, ', ', MCBFlags, ', ', Quoted(States^));
  297.   WriteLn(OutF, '));');
  298.   if Mask <> -1 then
  299.     WriteLn(OutF, 'PCluster('+VarName^+')^.SetButtonState($', Hex8(not Mask), ', False);');
  300.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  301.   DoOpEvent(P, VarName^);
  302.   WriteLn(OutF, 'Insert(', VarName^, ');');
  303.   end;
  304. end;
  305.  
  306. procedure WriteHistory(P : PScriptRec);
  307. begin
  308. with P^, MainBlock do
  309.   begin
  310.   Write(OutF, '  ');
  311.   RDotAssign(P);
  312.   WriteLn(OutF, '  Insert(New(PHistory, Init(R, PInputline(',
  313.                     HistoryLink^, '), ', HistoryID, ')));');
  314.   end;
  315. end;
  316.  
  317. procedure WriteStaticText(P : PScriptRec);
  318.   procedure DoText;  {split Text into short lines if it is long}
  319.                      {convert single quotes to double}
  320.   var
  321.     I, Count, TextLeng : Integer;
  322.     Ch : char;
  323.     S : string[20];
  324.   begin
  325.   Count := 38;
  326.   with P^ do
  327.     begin
  328.     I := 1;
  329.     TextLeng := Length(Text^);
  330.     while I <= TextLeng do
  331.       begin
  332.       Ch := Text^[I];
  333.       if Ch = ^M then
  334.          begin
  335.          if I >= TextLeng then
  336.             S := ''    {on the end}
  337.          else S := '''^M+'^M^J'     ''';
  338.          Count := 0;
  339.          end
  340.       else if Ch = '''' then
  341.          S := ''''''    {one quote to two}
  342.       else S := Ch;
  343.       Write(OutF, S);
  344.       Inc(Count, Length(S));
  345.       if (Count >= 75) and (I < TextLeng) then
  346.         begin
  347.         Write(OutF, '''+'^M^J'     ''');
  348.         Count := 5;
  349.         end;
  350.       Inc(I);
  351.       end;
  352.     end;
  353.   end;
  354.  
  355. begin
  356. with P^, MainBlock do
  357.   begin
  358.   RDotAssign(P);
  359.   Write(OutF, VarName^, ' := New('+Obj^+', Init(R, ''');
  360.   DoText;
  361.   Write(OutF, '''');
  362.   if Kind = SText then
  363.     WriteLn(OutF, '));')
  364.   else
  365.     WriteLn(OutF, ', $', Hex2(Byte(Attrib)), '));');
  366.   DoOpEvent(P, VarName^);
  367.   WriteLn(OutF, 'Insert(', VarName^, ');');
  368.   end;
  369. end;
  370.  
  371. procedure WriteLabel(P : PScriptRec);
  372. begin
  373. with P^, MainBlock do
  374.   begin
  375.   Write(OutF, '  ');
  376.   RDotAssign(P);
  377.   WriteLn(OutF, '  Insert(New('+Obj^+', Init(R, '+
  378.           Quoted(LabelText^)+', ', LinkName^, ')));' );
  379.   end;
  380. end;
  381.  
  382. procedure FormDialog;
  383.  
  384.   procedure DoControls(P : PScriptRec); far;
  385.   begin
  386.   case P^.Kind of
  387.     Button: WriteButton(P);
  388.     InputL: WriteInputLine(P);
  389.     Labl: WriteLabel(P);
  390.     Histry: WriteHistory(P);
  391.     ILong: WriteInputLong(P);
  392.     CheckB, RadioB, MultiCB:
  393.            WriteCheckRadio(P);
  394.     ListB: WriteListBox(P);
  395.     ScrollB: WriteScrollBar(P);
  396.     Memo:  WriteMemo(P);
  397.     CText, SText: WriteStaticText(P);
  398.     end;
  399.   WriteLn(OutF);
  400.   end;
  401.  
  402. begin
  403. with Dialog^, MainBlock do
  404.   begin
  405.   RDotAssign(Dialog);
  406.   WriteLn(Outf, 'inherited Init(R, ', Quoted(Title^), ');');
  407.  
  408.   if DefOptns <> Optns then
  409.     WriteLn(Outf, 'Options := Options',
  410.                   OptionStr(Optns, DefOptns, GetOptionWords));
  411.   if DefEvMsk <> EvMsk then
  412.     WriteLn(Outf, 'EventMask := EventMask',
  413.                   OptionStr(EvMsk, DefEvMsk, GetEventWords));
  414.   WriteHelpCtx(Nil, HelpCtxSym^, HCtx);
  415.   if Palette <> dpGrayDialog then
  416.     begin
  417.     if Palette = dpBlueDialog then S := 'dpBlueDialog'
  418.       else S := 'dpCyanDialog';
  419.     WriteLn(Outf, 'Palette := ', S, ';');
  420.     end;
  421.  
  422.   if WinFlags <> 5 then
  423.     WriteLn(Outf, 'Flags := Flags',
  424.                   OptionStr(WinFlags, 5, GetWinFlagWords));
  425.   WriteLn(OutF);
  426.  
  427.   ScriptColl^.ForEach(@DoControls);
  428.   end;
  429. end;
  430.  
  431. procedure DoTheVars;
  432. var
  433.   DidSomething : boolean;
  434.  
  435.   procedure DoVars(P : PScriptRec); far;
  436.   var
  437.     Control1 : boolean;
  438.   begin
  439.   with P^, MainBlock do
  440.     begin
  441.     Control1 := SameString(VarName^, 'Control1');
  442.     NeedControl1 := NeedControl1 or Control1;  {see if Control1 var will be needed}
  443.     if (VarName^ <> '') and not SameString(VarName^, 'Control')
  444.         and not Control1 then
  445.       begin
  446.       WriteLn(OutF, '    ', VarName^, ' : ', Obj^, ';');
  447.       DidSomething := True;
  448.       end;
  449.     end;
  450.   end;
  451. begin
  452. DidSomething := False;
  453. ScriptColl^.ForEach(@DoVars);
  454. if DidSomething then WriteLn(OutF);  {extra line}
  455. end;
  456.  
  457. procedure SubViewPtr(Load : boolean);
  458.  
  459.   procedure DoVars(P : PScriptRec); far;
  460.   begin
  461.   with P^, MainBlock do
  462.     if (VarName^ <> '') and not SameString(VarName^, 'Control')
  463.             and not SameString(VarName^, 'Control1') then
  464.         begin
  465.         if Load then Write(OutF, 'GetSubViewPtr(S, ')
  466.         else Write(OutF, 'PutSubViewPtr(S, ');
  467.         WriteLn(OutF, VarName^, ');');
  468.         end;
  469.   end;
  470. begin
  471. ScriptColl^.ForEach(@DoVars);
  472. end;
  473.  
  474. procedure DoDataRecord;
  475. var
  476.   First : boolean;
  477.  
  478.   procedure DoFields(P : PScriptRec); far;
  479.   var
  480.     S : string[15];
  481.   begin
  482.   with P^, MainBlock do
  483.     if FieldName^ <> '' then
  484.       begin
  485.       if First then  {at least one fieldname to output}
  486.         begin
  487.         WriteLn(OutF, '  ', Dialog^.MainBlock.FieldName^, ' = record');
  488.         First := False;
  489.         end;
  490.       Write(OutF, '    ', FieldName^);
  491.       case Kind of
  492.         CheckB, RadioB :
  493.            Write(OutF, ' : Word;');
  494.         MultiCB, ILong :
  495.            Write(OutF, ' : LongInt;');
  496.         InputL :
  497.           begin
  498.           if (ValKind = Range) and (Transfer <> 0) then
  499.              Write(OutF, ' : LongInt;')
  500.           else
  501.             begin
  502.             Str(StringLeng, S);
  503.             Write(OutF, ' : String['+S+'];');
  504.             end;
  505.           end;
  506.         ListB :
  507.           Write(OutF, ' : TListBoxRec;');
  508.         Memo :
  509.           begin
  510.           WriteLn(OutF, ' : Word;');
  511.           Str(BufSize, S);
  512.           Write(OutF, '    ', TextFieldName^, ' : Array[1..'+S+'] of Char;');
  513.           end;
  514.         end;
  515.       WriteLn(OutF);
  516.       end;
  517.   end;
  518.  
  519. begin
  520. with Dialog^, MainBlock do
  521.   begin
  522.   if Present[ListB] then  {make sure TListBoxRec is defined}
  523.     WriteLn(OutF,
  524.     '  TListBoxRec = record    {<-- omit if TListBoxRec is defined elsewhere}'^M^J+
  525.     '    List: PCollection;'^M^J+
  526.     '    Selection: Word;'^M^J+
  527.     '  end;'^M^J);
  528.  
  529.   First := True;
  530.   ScriptColl^.ForEach(@DoFields);
  531.   if not First then    {if First still set, there is no data record}
  532.     begin
  533.     WriteLn(OutF, '    end;');
  534.     WriteLn(OutF, '  P'+FieldName^, ' = ^', FieldName^, ';');
  535.     end;
  536.   end;
  537. end;
  538.  
  539. function FindSkelDat: string;
  540. {look for 'skel.dat' in the directory where this file was found}
  541. var
  542.   EXEName, Dir : PathStr;
  543.   Ext : ExtStr;
  544.   Name : NameStr;
  545. begin
  546. if Lo(DosVersion) >= 3 then EXEName := ParamStr(0)
  547. else EXEName := FSearch('PASSRC2.EXE', GetEnv('PATH'));
  548. FSplit(EXEName, Dir, Name, Ext);
  549. if Dir[Length(Dir)] = '\' then Dec(Dir[0]);
  550. FindSkelDat := FSearch('SKEL.DAT', Dir);
  551. end;
  552.  
  553. function HeapFunc(Size : word) : integer; far;
  554. begin
  555. if Size > 0 then
  556.   begin
  557.   WriteLn('Out of memory');
  558.   Halt(1);
  559.   end;
  560. end;
  561.  
  562. var
  563.   I : Integer;
  564.   Inf : Text;
  565.  
  566. begin
  567. HeapError := @HeapFunc;
  568.  
  569. if ParamCount < 2 then
  570.   begin
  571.   WriteLn('Usage:  passrc2 <script filename> <source filename> [error filename]');
  572.   Halt(1);
  573.   end;
  574. if ParamCount >= 3 then
  575.   begin
  576.   Assign(OutPut, ParamStr(3));   {the error file}
  577.   ReWrite(Output);
  578.   end;
  579. {$I-}
  580. Assign(Inf, FindSkelDat);    {find the data file, skel.dat}
  581. Reset(Inf);
  582. ChkIOError('skel.dat');
  583.  
  584. ReadScriptFile( DefaultExt (ParamStr(1), '.SCP'));  {ParamStr(1) is script file}
  585.  
  586. Assign(OutF, DefaultExt (ParamStr(2), '.PAS'));    {ParamStr(2) is output source file}
  587. Rewrite(OutF);
  588. ChkIOError(DefaultExt (ParamStr(2), '.PAS'));
  589. {$I+}
  590.  
  591. while not Eof(Inf) do
  592.   begin
  593.   ReadLn(Inf, S);
  594.   if S = '@ZZ0' then FormDialog
  595.   else if S = '@ZZ1' then DoTheVars
  596.   else if S = '@ZZ2' then DoDataRecord
  597.   else if S = '@ZZ3' then SubViewPtr(True)
  598.   else if S = '@ZZ4' then SubViewPtr(False)
  599.   else
  600.     begin
  601.     I := Pos('@XX', S);
  602.     while I > 0 do
  603.       begin
  604.       Subst(I);
  605.       I := Pos('@XX', S);
  606.       end;
  607.     WriteLn(OutF, S)
  608.     end;
  609.   end;
  610. Close(InF);
  611. Close(OutF);
  612. end.
  613.  
  614.