home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 153.img / TELES.ZIP / MENUEDIT.PAS < prev    next >
Pascal/Delphi Source File  |  1988-05-19  |  10KB  |  448 lines
  1. {$R-}    {Range checking off}
  2. {$B+}    {Boolean complete evaluation on}
  3. {$S+}    {Stack checking on}
  4. {$I+}    {I/O checking on}
  5. {$N-}    {No numeric coprocessor}
  6. {$V-}
  7.  
  8. Unit MenuEdit;
  9.  
  10. Interface
  11.  
  12. Uses
  13.   Crt,
  14.   Common;
  15.  
  16. Procedure Menu_Edit;
  17.  
  18. Var
  19.   C:Integer;
  20.   Changed:Boolean;
  21.   Exist:Boolean;
  22.  
  23. Implementation
  24.  
  25. procedure tc(i:integer);
  26. begin
  27.   textcolor(i);
  28. end;
  29.  
  30. procedure tb(i:integer);
  31. begin
  32.   textbackground(i);
  33. end;
  34.  
  35. function cstr(i:integer):astr;
  36. var c:astr;
  37. begin
  38.   str(i,c); cstr:=c;
  39. end;
  40.  
  41. function mln(i:astr; l:integer):astr;
  42. begin
  43.   while length(i)<l do i:=i+' ';
  44.   mln:=i;
  45. end;
  46.  
  47. function mn(i,l:integer):astr;
  48. begin
  49.   mn:=mln(cstr(i),l);
  50. end;
  51.  
  52. procedure makenewfile;
  53. var f:text;
  54. begin
  55.   textcolor(11);
  56.   write(n+' is a new file. Creating...');
  57.   assign(f,n);
  58.   rewrite(f);
  59.   writeln(f,'NULL');
  60.   writeln(f,'Command? ');
  61.   writeln(f,'C');
  62.   writeln(f,'10');
  63.   writeln(f,'2');
  64.   writeln(f,'0');
  65.   writeln(f,'Reason:');
  66.   close(f);
  67.   writeln('Ok');
  68. end;
  69.  
  70. procedure input1(var i:astr; ml:integer; tf:boolean);
  71. var cp:integer;
  72.     cc:char;
  73.     r:real;
  74. begin
  75.   cp:=1;
  76.   repeat
  77.     cc:=readkey;
  78.     if not tf then cc:=upcase(cc);
  79.     if (cc>=' ') and (cc<chr(127)) then
  80.       if cp<=ml then begin
  81.       i[cp]:=cc;
  82.       cp:=cp+1;
  83.       write(cc);
  84.     end else else case ord(cc) of
  85.       8:if cp>1 then begin
  86.                cc:=chr(8);
  87.                write(cc);write(' '); write(cc);
  88.                cp:=cp-1;
  89.              end;
  90.       21,24:while cp<>1 do begin
  91.                cp:=cp-1;
  92.                write(#8);write(' ');write(#8);
  93.              end;
  94.       end;
  95.   until (cc=#13) or (cc=#14);
  96.   i[0]:=chr(cp-1);
  97.   writeln;
  98. end;
  99.  
  100. procedure input(var i:astr; ml:integer);  (* Input uppercase only *)
  101. begin
  102.   input1(i,ml,false);
  103. end;
  104.  
  105. procedure inputl(var i:astr; ml:integer);   (* Input lower & upper case *)
  106. begin
  107.   input1(i,ml,true);
  108. end;
  109.  
  110. function value(I:astr):integer;
  111. var n,n1:integer;
  112. begin
  113.   val(i,n,n1);
  114.   if n1<>0 then begin
  115.     i:=copy(i,1,n1-1);
  116.     val(i,n,n1)
  117.   end;
  118.   value:=n;
  119.   if i='' then value:=0;
  120. end;
  121.  
  122. procedure inputn(var i:integer; ml:integer);
  123. var s:astr;
  124. begin
  125.   str(i,s);
  126.   input1(s,ml,false);
  127.   i:=value(s);
  128. end;
  129.  
  130. procedure cmdline;
  131. var x,y:integer; i:astr;
  132. begin
  133.   getdir(0,i);
  134.   x:=wherex; y:=wherey;
  135.   window(1,1,80,25);
  136.   tc(15); textbackground(1);
  137.   clreol; gotoxy(1,1);
  138.   write('Commands on Menu: ',c,' │ Editing: ',n,' │ Active Directory: '+i);
  139.   window(1,2,80,25);
  140.   tb(0); gotoxy(x,y);
  141. end;
  142.  
  143. procedure display;
  144. var i:integer;
  145. begin
  146.   writeln; writeln;
  147.   tc(15);
  148.   writeln('NN Command        MSL Type Option data Option String');
  149.   tc(9);
  150.   writeln('-- -------------- --- ---- ----------- ----------------------------------------');
  151.   tc(3);
  152.   for i:=1 to c do writeln(mn(i,3),mln(cmdl[i],15),mn(msl[i],4),mn(cmdtype[i],5),mn(optdata[i],12),optstr[i]);
  153. end;
  154.  
  155. procedure editcmd;
  156. var i,x,z:integer; r:char; s:astr;
  157. begin
  158.   display;
  159.   writeln;
  160.   tc(11);
  161.   write('Enter # to Edit   : ');
  162.   tc(10);
  163.   inputn(i,2);
  164.   repeat
  165.     writeln;
  166.     tc(14); writeln('CMD Information');
  167.     writeln;
  168.     tc(11); write('1> ');
  169.     tc(3);
  170.     write('Command String  :');
  171.     tc(10);
  172.     writeln(cmdl[i]);
  173.     tc(11); write('2> ');
  174.     tc(3);
  175.     write('Security Level  :');
  176.     tc(10);
  177.     writeln(msl[i]);
  178.     tc(11); write('3> ');
  179.     tc(3);
  180.     write('Command Type    :');
  181.     tc(10);
  182.     writeln(cmdtype[i]);
  183.     tc(11); write('4> ');
  184.     tc(3);
  185.     write('Optional Data   :');
  186.     tc(10);
  187.     writeln(optdata[i]);
  188.     tc(11); write('5> ');
  189.     tc(3);
  190.     write('Optional String :');
  191.     tc(10);
  192.     writeln(optstr[i]);
  193.     writeln;
  194.     tc(12);
  195.     write('Enter Selection [1-5] or Q=Quit  : ');
  196.     tc(10);
  197.     r:=readkey; r:=upcase(r);
  198.     write(r);
  199.     if r='1' then begin
  200.       writeln; tc(11); write('Enter new command string   : '); tc(10);
  201.       input(s,14); cmdl[i]:=s;
  202.     end;
  203.     if r='2' then begin
  204.       writeln; tc(11); write('Enter new Security Level   : '); tc(10);
  205.       inputn(z,3); msl[i]:=z;
  206.     end;
  207.     if r='3' then begin
  208.       writeln; tc(11); write('Enter new Command Type     : '); tc(10);
  209.       inputn(z,3); cmdtype[i]:=z;
  210.     end;
  211.     if r='4' then begin
  212.       writeln; tc(11); write('Enter new Optional Data    : '); tc(10);
  213.       inputn(z,3); optdata[i]:=z;
  214.     end;
  215.     if r='5' then begin
  216.       writeln; tc(11); write('Enter new Optional String  : '); tc(10);
  217.       inputl(s,40); optstr[i]:=s;
  218.     end;
  219.   until (r='Q');
  220. end;
  221.  
  222. procedure deletecmd;
  223. var i:integer; x:integer;
  224. begin
  225.   display;
  226.   writeln;
  227.   tc(11);Write('Enter # to delete  : ');
  228.   tc(10);
  229.   inputn(i,2);
  230.   for x:=i+1 to c do begin
  231.     cmdl[x-1]:=cmdl[x];
  232.     msl[x-1]:=msl[x];
  233.     cmdtype[x-1]:=cmdtype[x];
  234.     optdata[x-1]:=optdata[x];
  235.     optstr[x-1]:=optstr[x];
  236.   end;
  237.   c:=c-1;
  238.   cmdline;
  239. end;
  240.  
  241. procedure addcmd;
  242. var s:astr; z:integer;
  243. begin
  244.   c:=c+1;
  245.   writeln;
  246.   writeln;
  247.   tc(12);
  248.   writeln('Please enter following information');
  249.   writeln;
  250.   tc(11);
  251.   write('Command string   : '); textcolor(10); input(s,14); cmdl[c]:=s;
  252.   tc(11);
  253.   write('Security Level   : '); textcolor(10); inputn(z,3); msl[c]:=z;
  254.   tc(11);
  255.   write('Command Type     : '); textcolor(10); inputn(z,3); cmdtype[c]:=z;
  256.   tc(11);
  257.   write('Optional Data    : '); textcolor(10); inputn(z,3); optdata[c]:=z;
  258.   tc(11);
  259.   write('Optional String  : '); textcolor(10); inputl(s,40); optstr[c]:=s;
  260.   tc(12);
  261.   write('Cmd #',c,' added.');
  262.   cmdline;
  263. end;
  264.  
  265. procedure savemenu;
  266. var filv:text; i:integer;
  267. begin
  268.   writeln; writeln; tc(11);
  269.   assign(filv,n);
  270.   rewrite(filv);
  271.   writeln(filv,directive);
  272.   writeln(filv,menuprompt);
  273.   for i:=1 to c do begin
  274.     writeln(filv,cmdl[i]);
  275.     writeln(filv,msl[i]);
  276.     writeln(filv,cmdtype[i]);
  277.     writeln(filv,optdata[i]);
  278.     writeln(filv,optstr[i]);
  279.   end;
  280.   close(filv); writeln('Menu saved.');
  281.   changed:=false;
  282. end;
  283.  
  284. procedure asksave;
  285. var save:boolean; r:char;
  286. begin
  287.   writeln;
  288.   tc(11);
  289.   write(n+' not saved.  Save (Y/N) ? ');
  290.   tc(10);
  291.   repeat
  292.     r:=readkey;
  293.     r:=upcase(r);
  294.     if r='Y' then save:=true;
  295.     if r='N' then save:=false;
  296.   until (r='Y') or (r='N');
  297.   if r='Y' then writeln('Yes');
  298.   if r='N' then writeln('No');
  299.   if save then savemenu;
  300. end;
  301.  
  302. procedure readin;
  303. begin
  304.   c:=0;
  305.   assign(filv,n);
  306.   {$I-} reset(filv); {$I+}
  307.   if ioresult<>0 then begin writeln(n+' does not exist.'); exist:=false; end else
  308.   BEGIN
  309.   changed:=false;
  310.   readln(filv,directive);
  311.   readln(filv,menuprompt);
  312.   repeat
  313.     c:=c+1;
  314.     readln(filv,cmdl[c]);
  315.     readln(filv,msl[c]);
  316.     readln(filv,cmdtype[c]);
  317.     readln(filv,optdata[c]);
  318.     readln(filv,optstr[c]);
  319.   until (eof(filv));
  320.   cmdline;
  321.   EXIST:=TRUE;
  322.   END;
  323. end;
  324.  
  325. procedure workfile;
  326. var s:astr;
  327. begin
  328.   writeln;
  329.   if changed then asksave;
  330.   textcolor(11);
  331.   write('Enter new work file  : ');
  332.   textcolor(10);
  333.   input(s,8); N:=s;
  334.   n:='MENUS\'+n+'.MNU';
  335.   readin;
  336.   if exist=false then begin makenewfile; readin; end;
  337. end;
  338.  
  339. procedure directives;
  340. var s:astr; R:Char;
  341. begin
  342.   repeat
  343.   writeln;
  344.   tc(12);
  345.   write('Current Directives:');
  346.   writeln;
  347.   tc(11);
  348.   write('1> ');
  349.   tc(3);
  350.   writeln('File Printed   : ',directive);
  351.   tc(11);
  352.   write('2> ');
  353.   tc(3);
  354.   writeln('Menu Prompt    : ',menuprompt);
  355.   writeln; tc(11);
  356.   write('Enter Selection [1-2] or Q to quit : ');
  357.   tc(10);
  358.   r:=readkey; r:=upcase(r); writeln(r);
  359.   if (r='1') then begin
  360.     tc(12); writeln('Enter file printed.  DO NOT mark a extension if you want it to');
  361.     writeln('also print ANSI files to ansi users.'); writeln;
  362.     tc(11); write('File Printed    : ');
  363.     tc(10); input(s,12); directive:=s;
  364.   end;
  365.   if r='2' then begin
  366.      tc(12); writeln('Enter new menu prompt.  Use "^" for a command marker');
  367.      writeln('Use ^n where n is 0-9 for color, and cmd letters for');
  368.      writeln('strings.');
  369.      writeln;
  370.      tc(11); write('Menu Prompt    : ');
  371.      tc(10);
  372.      inputl(s,50); menuprompt:=s;
  373.    end;
  374.   until (r='Q');
  375. end;
  376.  
  377. procedure changedir;
  378. var s:astr;
  379. begin
  380.   writeln;
  381.   tc(11);
  382.   write('Enter new directory  : ');
  383.   textcolor(10);
  384.   input(s,20);
  385.   chdir(s);
  386.   cmdline;
  387. end;
  388.  
  389. procedure menu;
  390. var r:char;
  391. begin
  392.   repeat
  393.   tc(14);
  394.   writeln;
  395.   writeln;
  396.   write('W');tc(15);write('ork file      ');tc(14);
  397.   write('A');tc(15);write('dd cmd to menu');
  398.   writeln;tc(14);
  399.   write('D');tc(15);write('isplay list   ');tc(14);
  400.   write('Q');tc(15);write('uit to DOS'); tc(14);writeln;
  401.   write('S');tc(15);write('ave menu file ');tc(14);
  402.   write('*');tc(15);write('Change directory');tc(14);writeln;
  403.   write('T');tc(15);write('erminate cmd  ');tc(14);
  404.   write('E');tc(15);write('dit a cmd'); writeln; tc(14);
  405.   write('X');tc(15);write('Command Directives.');
  406.   writeln;
  407.   writeln;
  408.   tc(10);
  409.   write('Cmd->');
  410.   r:=readkey;
  411.   r:=upcase(r); textcolor(13);
  412.   write(r);
  413.   if (r='A') or (r='T') or (r='E') then changed:=true;
  414.   if r='D' then display;
  415.   if r='A' then addcmd;
  416.   if r='W' then workfile;
  417.   if r='S' then savemenu;
  418.   if r='*' then changedir;
  419.   if r='T' then deletecmd;
  420.   if r='E' then editcmd;
  421.   IF R='X' THEN directives;
  422.   until (r='Q');
  423.   if changed then asksave;
  424. end;
  425.  
  426. Procedure Menu_Edit;
  427. var i:integer; r:char;
  428. begin
  429.   clrscr;
  430.   changed:=false;
  431.   for i:=1 to 50 do begin
  432.     cmdl[i]:='';
  433.     msl[i]:=0;
  434.     cmdtype[i]:=0;
  435.     optdata[i]:=0;
  436.     optstr[i]:='';
  437.   end;
  438.   n:='MENUS\MAIN.MNU'; readin;
  439.   clrscr;
  440.   cmdline;
  441.   writeln;
  442.   tc(12);
  443.   write('Telegard BBS MenuEdit -- V 1.0 By Carl Mueller');
  444.   writeln;
  445.   menu;
  446. end;
  447.  
  448. END.