home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / UTILS / DLGDS4 / PASSRC1.PAS < prev    next >
Pascal/Delphi Source File  |  1993-08-10  |  13KB  |  498 lines
  1. {$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
  2. {$M 16384,5000,655360}
  3.  
  4. Program PasSrc1;
  5.  
  6. uses Dos, Memory, Objects, Drivers, Views, Dialogs,
  7.      Editors, ColorTxt, InpLong, Validate, ReadScpt;
  8.  
  9. const
  10.   NeedControl1 : boolean = False;
  11. var
  12.   P : PScriptRec;
  13.   Outf : Text;
  14.   DlgName : string[50];  {holds dialog's variable name for easy reference}
  15.  
  16. function Positn(Pat, Src : String; I : Integer) : Integer;
  17. {find the position of a substring in a string starting at the Ith char}
  18. var
  19.   N : Integer;
  20. begin
  21. if I < 1 then I := 1;
  22. Delete(Src, 1, I-1);
  23. N := Pos(Pat, Src);
  24. if N = 0 then Positn := 0
  25.   else Positn := N+I-1;
  26. end;
  27.  
  28. FUNCTION Quoted(S : string) : string;
  29. {Puts single quotes around a string and doubles any internal single quotes}
  30. var
  31.   I : Integer;
  32. begin
  33. I := Pos('''', S);
  34. while I > 0 do
  35.   begin
  36.   Insert('''', S, I);
  37.   I := Positn('''', S, I+2);
  38.   end;
  39. Insert('''', S, 1);
  40. Quoted := S+'''';
  41. end;
  42.  
  43. procedure RDotAssign(P : PScriptRec);
  44. begin
  45. with P^.MainBlock do
  46.   begin
  47.   WriteLn(Outf, 'R.Assign(', X1, ', ', Y1, ', ', X2,', ', Y2, ');');
  48.   end;
  49. end;
  50.  
  51. procedure DoOpEvent(P : PScriptRec; const Sym : string);
  52. begin
  53. with P^.MainBlock do
  54.   begin
  55.   if DefOptns <> Optns then
  56.     WriteLn(Outf, Sym, '^.Options := ', Sym, '^.Options',
  57.                   OptionStr(Optns, DefOptns, GetOptionWords));
  58.   if DefEvMsk <> EvMsk then
  59.     WriteLn(Outf, Sym, '^.EventMask := ', Sym, '^.EventMask',
  60.                   OptionStr(EvMsk, DefEvMsk, GetEventWords));
  61.   end;
  62. end;
  63.  
  64. PROCEDURE WriteHelpCtx(Rf : PString; H : String; Ctx : word);
  65. Const
  66.   NoContext : String[11] = 'hcNoContext';
  67. begin
  68. if (H = '') and (Ctx > 0) then
  69.    Str(Ctx, H);
  70. if (H <> '') and not SameString(H, NoContext) then
  71.   WriteLn(OutF, Rf^, '^.HelpCtx := ', H, ';' );
  72. end;
  73.  
  74. procedure WriteButton(P : PScriptRec); {write code for TButton}
  75. var
  76.   S : string[55];
  77.  
  78.   function FlagStr : string;
  79.   var
  80.     S : string[55];
  81.   begin
  82.   with P^ do
  83.     begin
  84.     S := '';
  85.     if Flags = 0 then S := 'bfNormal'
  86.     else
  87.       begin
  88.       if Flags and 1 <> 0 then S := 'bfDefault or ';
  89.       if Flags and 2 <> 0 then S := S+'bfLeftJust or ';
  90.       if Flags and 4 <> 0 then S := S+'bfBroadcast or ';
  91.       if Flags and 8 <> 0 then S := S+'bfGrabFocus or ';
  92.       Dec(S[0], 4);  {remove extra ' or '}
  93.       end;
  94.     end;
  95.   FlagStr := S;
  96.   end;
  97.  
  98. begin
  99. with P^, MainBlock do
  100.   begin
  101.   RDotAssign(P);
  102.   if SameString(Obj^, 'POptionButton') then  {a special TOptionButton}
  103.     WriteLn(OutF, VarName^, ' := New(', Obj^, ', Init(R, ', Param[1]^,
  104.          ', '+Param[2]^+'));' )
  105.   else
  106.     begin   {regular button}
  107.     if CommandName^ <> '' then S := CommandName^
  108.       else Str(CommandValue, S);
  109.     Write(OutF, VarName^, ' := New(', Obj^, ', Init(R, ',
  110.          Quoted(ButtonText^), ', '+S+', ' );
  111.     WriteLn(OutF, FlagStr+'));' );
  112.     end;
  113.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  114.   DoOpEvent(P, VarName^);
  115.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  116.   end;
  117. end;
  118.  
  119. procedure WriteInputLong(P : PScriptRec);  {code for TInputLong}
  120. begin
  121. with P^, MainBlock do
  122.   begin
  123.   RDotAssign(P);
  124.   WriteLn(OutF,
  125.          VarName^, ' := New('+Obj^+', Init(R, ', LongStrLeng,
  126.          ', ', LLim, ', ', ULim,  ', ', ILOptions, '));' );
  127.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  128.   DoOpEvent(P, VarName^);
  129.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  130.   end;
  131. end;
  132.  
  133. procedure WriteInputLine(P : PScriptRec); {code for TInputLine}
  134. var
  135.   S : string[15];
  136. begin
  137. with P^, MainBlock do
  138.   begin
  139.   RDotAssign(P);
  140.   WriteLn(OutF,
  141.          VarName^, ' := New('+Obj^+', Init(R, ', StringLeng, '));' );
  142.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  143.   DoOpEvent(P, VarName^);
  144.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  145.  
  146.   if ValKind in [Picture..StringLookup] then
  147.     begin
  148.     Write(OutF, '  ', Obj^+'('+VarName^+')^.Validator := New(', ValPtrName^,
  149.         ', Init(');
  150.     case ValKind of
  151.       Picture:
  152.          begin
  153.          if AutoFill <> 0 then S := 'True' else S := 'False';
  154.          WriteLn(OutF, Quoted(PictureString^), ', ', S, '));');
  155.          end;
  156.       Range:
  157.          begin
  158.          WriteLn(OutF, LowLim, ', ', UpLim, '));');
  159.          if Transfer <> 0 then
  160.            WriteLn(OutF, '  ',
  161.                Obj^+'('+VarName^+')^.Validator^.Options := voTransfer;');
  162.          end;
  163.       Filter:
  164.          WriteLn(OutF, CharSet^, '));');
  165.       StringLookup:
  166.          WriteLn(OutF, List^, '));');
  167.       end;
  168.     end;
  169.   end;
  170. end;
  171.  
  172. procedure WriteMemo(P : PScriptRec);
  173. begin
  174. with P^, MainBlock do
  175.   begin
  176.   RDotAssign(P);
  177.   Write(OutF,
  178.          VarName^, ' := New('+Obj^+', Init(R, ');
  179.   if HScroll^ <> '' then
  180.     Write(OutF, 'PScrollbar(Control1), ')
  181.   else Write(OutF, 'Nil, ' );
  182.   if VScroll^ <> '' then
  183.     Write(OutF, 'PScrollbar(Control), ')
  184.   else Write(OutF, 'Nil, ' );
  185.   WriteLn(OutF, 'Nil, ', BufSize, '));');
  186.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  187.   DoOpEvent(P, VarName^);
  188.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  189.   end;
  190. end;
  191.  
  192. procedure WriteListBox(P : PScriptRec);
  193. begin
  194. with P^, MainBlock do
  195.   begin
  196.   RDotAssign(P);
  197.   Write(OutF,
  198.          VarName^, ' := New('+Obj^+', Init(R, ', Columns);
  199.   if Scrollbar^ <> '' then
  200.     WriteLn(OutF, ', PScrollbar('+ScrollBar^+')));')
  201.   else WriteLn(OutF, ', Nil));' );
  202.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  203.   DoOpEvent(P, VarName^);
  204.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  205.   end;
  206. end;
  207.  
  208. procedure WriteScrollBar(P : PScriptRec);
  209. begin
  210. with P^, MainBlock do
  211.   begin
  212.   RDotAssign(P);
  213.   WriteLn(OutF,
  214.          VarName^, ' := New('+Obj^+', Init(R));');
  215.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  216.   DoOpEvent(P, VarName^);
  217.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  218.   end;
  219. end;
  220.  
  221. procedure WriteCheckRadio(P : PScriptRec);
  222. var
  223.   I : integer;
  224.  
  225.   function MCBFlagString(Flags : word) : string;
  226.   var
  227.     S : string[30];
  228.   begin
  229.   if Flags = $101 then S := 'cfOneBit'
  230.   else if Flags = $203 then S := 'cfTwoBits'
  231.   else if Flags = $40F then S := 'cfFourBits'
  232.   else if Flags = $8FF then S := 'cfEightBits'
  233.   else S := '$'+Hex4(Flags);
  234.   MCBFlagString := S;
  235.   end;
  236.  
  237. begin
  238. with P^, MainBlock do
  239.   begin
  240.   RDotAssign(P);
  241.   Write(OutF,
  242.          VarName^, ' := New('+Obj^+', Init(R, ');
  243.   for I := 0 to Items-1 do
  244.     Write(OutF, ^M^J'  NewSItem(', Quoted(PString(LabelColl^.At(I))^), ',');
  245.   Write(OutF, ' Nil)');
  246.   for I := 1 to Items-1 do
  247.     Write(OutF, ')');
  248.   if Kind = MultiCB then
  249.     Write(OutF, ', ', SelRange, ', ', MCBFlagString(MCBFlags), ', ', Quoted(States^));
  250.   WriteLn(OutF, '));');
  251.   if Mask <> -1 then
  252.     WriteLn(OutF, 'PCluster('+VarName^+')^.SetButtonState($', Hex8(not Mask), ', False);');
  253.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  254.   DoOpEvent(P, VarName^);
  255.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  256.   end;
  257. end;
  258.  
  259. procedure WriteHistory(P : PScriptRec);
  260. begin
  261. with P^, MainBlock do
  262.   begin
  263.   Write(OutF, '  ');
  264.   RDotAssign(P);
  265.   WriteLn(OutF, '  ', DlgName, '^.Insert(New(PHistory, Init(R, PInputline(',
  266.                     HistoryLink^, '), ', HistoryID, ')));');
  267.   end;
  268. end;
  269.  
  270. procedure WriteStaticText(P : PScriptRec);
  271.   procedure DoText;  {split Text into short lines if it is long}
  272.                      {convert single quotes to double}
  273.   var
  274.     I, Count, TextLeng : Integer;
  275.     Ch : char;
  276.     S : string[20];
  277.   begin
  278.   Count := 38;
  279.   with P^ do
  280.     begin
  281.     I := 1;
  282.     TextLeng := Length(Text^);
  283.     while I <= TextLeng do
  284.       begin
  285.       Ch := Text^[I];
  286.       if Ch = ^M then
  287.          begin
  288.          if I >= TextLeng then
  289.             S := ''    {on the end}
  290.          else S := '''^M+'^M^J'     ''';
  291.          Count := 0;
  292.          end
  293.       else if Ch = '''' then
  294.          S := ''''''    {one quote to two}
  295.       else S := Ch;
  296.       Write(OutF, S);
  297.       Inc(Count, Length(S));
  298.       if (Count >= 75) and (I < TextLeng) then
  299.         begin
  300.         Write(OutF, '''+'^M^J'     ''');
  301.         Count := 5;
  302.         end;
  303.       Inc(I);
  304.       end;
  305.     end;
  306.   end;
  307.  
  308. begin
  309. with P^, MainBlock do
  310.   begin
  311.   RDotAssign(P);
  312.   Write(OutF, VarName^, ' := New('+Obj^+', Init(R, ''');
  313.   DoText;
  314.   Write(OutF, '''');
  315.   if Kind = SText then
  316.     WriteLn(OutF, '));')
  317.   else
  318.     WriteLn(OutF, ', $', Hex2(Byte(Attrib)), '));');
  319.   DoOpEvent(P, VarName^);
  320.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  321.   end;
  322. end;
  323.  
  324. procedure WriteLabel(P : PScriptRec);
  325. begin
  326. with P^, MainBlock do
  327.   begin
  328.   Write(OutF, '  ');
  329.   RDotAssign(P);
  330.   WriteLn(OutF, '  ', DlgName, '^.Insert(New('+Obj^+', Init(R, '+
  331.           Quoted(LabelText^)+', ', LinkName^, ')));' );
  332.   end;
  333. end;
  334.  
  335. procedure WriteSource;
  336. var
  337.   First : boolean;
  338.   S : string[30];
  339.   I : integer;
  340.  
  341.   procedure DoControls(P : PScriptRec); far;
  342.   begin
  343.   case P^.Kind of
  344.     Button: WriteButton(P);
  345.     InputL: WriteInputLine(P);
  346.     Labl: WriteLabel(P);
  347.     Histry: WriteHistory(P);
  348.     ILong: WriteInputLong(P);
  349.     CheckB, RadioB, MultiCB:
  350.            WriteCheckRadio(P);
  351.     ListB: WriteListBox(P);
  352.     ScrollB: WriteScrollBar(P);
  353.     Memo:  WriteMemo(P);
  354.     CText, SText: WriteStaticText(P);
  355.     end;
  356.   WriteLn(OutF);
  357.   end;
  358.  
  359.   procedure DoVars(P : PScriptRec); far;
  360.   begin
  361.   with P^, MainBlock do
  362.     if (VarName^ <> '') and not SameString(VarName^, 'Control')
  363.         and not SameString(VarName^, 'Control1') then
  364.       WriteLn(OutF, '  ', VarName^, ' : ', Obj^, ';');
  365.   end;
  366.  
  367.   procedure DoFields(P : PScriptRec); far;
  368.   var
  369.     S : string[15];
  370.  
  371.     procedure ChkFirst;
  372.     begin
  373.     if First then  {at least one fieldname to output}
  374.       begin
  375.       WriteLn(OutF, 'var'^M^J'  ', Dialog^.MainBlock.FieldName^, ' : record');
  376.       First := False;
  377.       end;
  378.     end;
  379.  
  380.   begin
  381.   with P^, MainBlock do
  382.     if FieldName^ <> '' then
  383.       begin
  384.       ChkFirst;
  385.       Write(OutF, '    ', FieldName^);
  386.       case Kind of
  387.         CheckB, RadioB :
  388.            WriteLn(OutF, ' : Word;');
  389.         MultiCB, ILong :
  390.            WriteLn(OutF, ' : LongInt;');
  391.         InputL :
  392.           begin
  393.           if (ValKind = Range) and (Transfer <> 0) then
  394.              WriteLn(OutF, ' : LongInt;')
  395.           else
  396.             begin
  397.             Str(StringLeng, S);
  398.             WriteLn(OutF, ' : String['+S+'];');
  399.             end;
  400.           end;
  401.         ListB :
  402.           WriteLn(OutF, ' : TListBoxRec;');
  403.         Memo :
  404.           begin
  405.           WriteLn(OutF, ' : Word;');
  406.           Str(BufSize, S);
  407.           WriteLn(OutF, '    ', TextFieldName^, ' : Array[1..'+S+'] of Char;');
  408.           NeedControl1 := NeedControl1 or (HScroll^ <> '');
  409.           end;
  410.         end;
  411.       end
  412.     else if SameString(Obj^, 'POptionButton') then
  413.       begin            {it's a special, fieldname is in parameter 3}
  414.       ChkFirst;
  415.       WriteLn(OutF, '    ', Param[3]^, ' : OptionRec;');
  416.       end;
  417.   end;
  418.  
  419. begin
  420. with Dialog^, MainBlock do
  421.   begin
  422.   DlgName := VarName^;
  423.   First := True;
  424.   ScriptColl^.ForEach(@DoFields);
  425.   if not First then   {if First still set, there is no data record}
  426.     WriteLn(OutF, '  end;'^M^J);
  427.  
  428.   WriteLn(Outf, 'function ', DlgFuncName^, ' : ', Obj^, ';');
  429.   Write(Outf, 'var'^M^J'  ', DlgName, ' : PDialog;'^M^J'  R : TRect;'^M^J'  '+
  430.              'Control');
  431.   if NeedControl1 then
  432.     WriteLn(OutF, ', Control1 : PView;')
  433.   else WriteLn(OutF, ' : PView;');
  434.  
  435.   ScriptColl^.ForEach(@DoVars);
  436.  
  437.   WriteLn(OutF, ^M^J'begin');
  438.   RDotAssign(Dialog);
  439.   WriteLn(Outf, 'New(', DlgName, ', Init(R, ', Quoted(Title^), '));');
  440.   DoOpEvent(Dialog, DlgName);
  441.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  442.   if Palette <> dpGrayDialog then
  443.     begin
  444.     if Palette = dpBlueDialog then S := 'dpBlueDialog'
  445.       else S := 'dpCyanDialog';
  446.     WriteLn(Outf, VarName^, '^.Palette := ', S, ';');
  447.     end;
  448.  
  449.   if WinFlags <> 5 then
  450.     WriteLn(Outf, VarName^, '^.Flags := ', VarName^, '^.Flags',
  451.                   OptionStr(WinFlags, 5, GetWinFlagWords));
  452.   WriteLn(OutF);
  453.  
  454.   ScriptColl^.ForEach(@DoControls);   {all the controls in dialog}
  455.  
  456.   S := DlgFuncName^;
  457.   I := Pos('.', S);  {remove 'TMyApp.' from 'TMyApp.MakeDialog'}
  458.   if I > 0 then Delete(S, 1, I);
  459.   WriteLn(Outf, DlgName, '^.SelectNext(False);'^M^J, S, ' := ',
  460.                 DlgName, ';'^M^J'end;');
  461.   end;
  462. end;
  463.  
  464.  
  465. function HeapFunc(Size : word) : integer; far;
  466. begin
  467. if Size > 0 then
  468.   begin
  469.   WriteLn('Out of memory');
  470.   Halt(1);
  471.   end;
  472. end;
  473.  
  474. begin
  475. HeapError := @HeapFunc;
  476.  
  477. if ParamCount < 2 then
  478.   begin
  479.   WriteLn('Usage:  passrc1 <script filename> <source filename> [error filename]');
  480.   Halt(1);
  481.   end;
  482. if ParamCount >= 3 then
  483.   begin   {redirect output to error file}
  484.   Assign(OutPut, ParamStr(3));   {the error file}
  485.   ReWrite(Output);
  486.   end;
  487. {$I-}
  488.  
  489. ReadScriptFile( DefaultExt (ParamStr(1), '.SCP'));  {ParamStr(1) is script file}
  490.  
  491. Assign(OutF, DefaultExt (ParamStr(2), '.SRC'));    {ParamStr(2) is output source file}
  492. Rewrite(OutF);
  493. ChkIOError(DefaultExt (ParamStr(2), '.SRC'));
  494.  
  495. WriteSource;
  496. Close(Outf);
  497. end.
  498.