home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TURMENU.ZIP / TURMENU.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1986-03-01  |  51.9 KB  |  1,684 lines
  1.  { Turbo Menu program for IBM/IBM clones running MSDOS/PCDOS.  This program
  2.  implements a WANG PC style menu interface.  This program can be not be
  3.  sold or used commerically.  You may give this program away for free to
  4.  nayone who would like it as long as the source code is included.
  5.  
  6.  Gary Miller Perception Technology Corp.
  7.  P.O. Box 176
  8.  Waterford, NY 12188
  9.  
  10.  CompuServe ID [70127,3674]
  11.  
  12.  }
  13.  
  14. Program Menu;
  15.   {$C-,V-}
  16.   {*Include File     STRING.INC ***** START *****}
  17.   {- Declare standard string types for function/procedure calling }
  18.   {- sequence.                                                    }
  19.  
  20.  Type
  21.   Str1=String[1];                           { Turbo Pascal requires that     }
  22.   Str2=String[2];                           { all parameters have a declared }
  23.   Str3=String[3];                           { type.  Since strings of varying}
  24.   Str4=String[4];                           { length must have different type}
  25.   Str5=String[5];                           { this file exists to be included}
  26.   Str6=String[6];                           { to make sure that the string   }
  27.   Str7=String[7];                           { types are declared.            }
  28.   Str8=String[8];                           { .............................. }
  29.   Str9=String[9];                           { .............................. }
  30.   Str10=String[10];                         { .............................. }
  31.   Str80=String[80];                         { 80 char string                 }
  32.   Str255=String[255];                       { Maximum string                 }
  33.  
  34.  
  35.   {*Include File End STRING.INC ***** END *****}
  36.  
  37.  Var
  38.   Ok:Boolean;
  39.   SwitchChar:Char;
  40.   NormalCursor:Integer;
  41.   NoCursor:Integer;
  42.  
  43.   {*Include File     ATTKBD.CON ***** START *****}
  44.  
  45.   { ***************************************************************** }
  46.   { ATT PC Keyboard definitions }
  47.   { ***************************************************************** }
  48.  
  49.  Const
  50.   RETURN_Key=#$0D;
  51.   BACKSPACE_Key=#$08;
  52.   ESCAPE_Key=#$1B;
  53.   BEEP_Key=#$07;
  54.   PREAMBLE_Key=#$00;
  55.   PREAMBLE_Byte=$00;
  56.   UP_Key=#$48;
  57.   DOWN_Key=#$50;
  58.   RIGHT_Key=#$4D;
  59.   LEFT_Key=#$4B;
  60.   HOME_Key=#$47;
  61.   INSERT_Key=#$52;
  62.   DELETE_Key=#$53;
  63.   PageDwn_Key=#$51;
  64.   PageUp_Key=#$49;
  65.   END_Key=#$4F;
  66.   TAB_Key=#$09;
  67.   BACKTAB_Key=#$0F;
  68.  
  69.   CTRL_LEFT_Key=#$73;
  70.   CTRL_RIGHT_Key=#$74;
  71.   CTRL_END_Key=#$75;
  72.   CTRL_PageDwn_Key=#$76;
  73.   CTRL_HOME_Key=#$77;
  74.   CTRL_PageUp_Key=#$84;
  75.  
  76.   SFKey01=#$3B;
  77.   SFKey02=#$3C;
  78.   SFKey03=#$3D;
  79.   SFKey04=#$3E;
  80.   SFKey05=#$3F;
  81.   SFKey06=#$40;
  82.   SFKey07=#$41;
  83.   SFKey08=#$42;
  84.   SFKey09=#$43;
  85.   SFKey10=#$44;
  86.  
  87.   Shift_SFKey01=#$54;
  88.   Shift_SFKey02=#$55;
  89.   Shift_SFKey03=#$56;
  90.   Shift_SFKey04=#$57;
  91.   Shift_SFKey05=#$58;
  92.   Shift_SFKey06=#$59;
  93.   Shift_SFKey07=#$5A;
  94.   Shift_SFKey08=#$5B;
  95.   Shift_SFKey09=#$5C;
  96.   Shift_SFKey10=#$5D;
  97.  
  98.   Alt_SFKey01=#$68;
  99.   Alt_SFKey02=#$69;
  100.   Alt_SFKey03=#$6A;
  101.   Alt_SFKey04=#$6B;
  102.   Alt_SFKey05=#$6C;
  103.   Alt_SFKey06=#$6D;
  104.   Alt_SFKey07=#$6E;
  105.   Alt_SFKey08=#$6F;
  106.   Alt_SFKey09=#$70;
  107.   Alt_SFKey10=#$71;
  108.  
  109.   { ***************************************************************** }
  110.  
  111.  
  112.   {*Include File End ATTKBD.CON ***** END *****}
  113.   {*Include File     CURSOR.INC ***** START *****}
  114.   { Set Cursor Size : subfunction 01h of Intr 10h.
  115.   The Documentation in the ATT Systems Programmers Guide did not
  116.   describe what the actual call does, but after experimenting the
  117.   meaning of start and end line is now clear.
  118.   The cursor size in the ATT is saved at 0040:0060; and is lines 6 - 7.
  119.  
  120.   }
  121.  
  122.  Procedure CursorSize(NewCursor:Integer);
  123.    { This procedure call the BIOS throught interrupt 10H to set
  124.    the top and bottom line of the cursor.  Scan Lines are
  125.    hardware dependent so you will have to experiment to find
  126.    what works on your system.                                }
  127.  
  128.   Type
  129.    Register=Record Case Boolean Of
  130.     True:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  131.     False:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  132.             End;
  133.   Var
  134.    Regs:Register;
  135.  
  136.   Begin
  137.    With Regs Do
  138.     Begin
  139.      ah:=$01;                               {ah = 1 means set cursor type}
  140.      bx:=$0;                                {bx = page number, zero for us}
  141.      cx:=NewCursor;                         {ch bits 4 to 0 = start line for cursor}
  142.      {*}                                    {cl bits 4 to 0 = end line for cursor}
  143.      cl:=(cl And $1F);                      {mask off all but low order 5 bits}
  144.      ch:=(ch And $1F);                      {do the same for ch, in case of programmer}
  145.      {*}                                    {error.  Can this happen? naw not a chance}
  146.      Intr($10,Regs);                        {set cursor}
  147.     End;
  148.   End;
  149.  
  150.  Procedure ReadCursor(Var CurrentCursor:Integer);
  151.    { This procedure call the BIOS throught interrupt 10H to read
  152.    the top and bottom line of the cursor.                        }
  153.  
  154.   Type
  155.    Register=Record Case Boolean Of
  156.     True:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  157.     False:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  158.             End;
  159.   Var
  160.    Regs:Register;
  161.  
  162.   Begin
  163.    With Regs Do
  164.     Begin
  165.      ah:=$03;                               {ah = 3 means read cursor     }
  166.      bx:=$0;                                {bx = page number, zero for us}
  167.      Intr($10,Regs);                        {read cursor                  }
  168.      CurrentCursor:=cx;                     {return current cursor lines  }
  169.      {*}                                    {row and col are in dx        }
  170.     End;
  171.   End;
  172.  
  173.   {*Include File End CURSOR.INC ***** END *****}
  174.   {*Include File     SCAN.INC ***** START *****}
  175.  Function Read_Char(Var extend:Boolean):Char;
  176.   Type
  177.    Register=Record Case Boolean Of
  178.     True:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  179.     False:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  180.             End;
  181.   Var
  182.    Regs:Register;
  183.   Begin
  184.    With Regs Do
  185.     Begin
  186.      ah:=$07;
  187.      MsDos(Regs);
  188.      If al=PREAMBLE_Byte Then
  189.       Begin
  190.        extend:=True;
  191.        MsDos(Regs);
  192.       End
  193.      Else
  194.       extend:=False;
  195.      Read_Char:=Chr(al);
  196.     End;
  197.   End;
  198.  
  199.   {*Include File End SCAN.INC ***** END *****}
  200.   {*Include File     INPUTUTI.INC ***** START *****}
  201.  Type
  202.   CharSet=Set Of Char;
  203.  
  204.  
  205.   {  UpcaseStr converts a string to upper case }
  206.  
  207.  Function UpcaseStr(S:Str80):Str80;
  208.   Var
  209.    P:Integer;
  210.   Begin
  211.    For P:=1 To Length(S) Do
  212.     S[P]:=UpCase(S[P]);
  213.    UpcaseStr:=S;
  214.   End;
  215.  
  216.   {  ConstStr returns a string with N characters of value C }
  217.  
  218.  Function ConstStr(C:Char;N:Integer):Str80;
  219.   Var
  220.    S:String[80];
  221.   Begin
  222.    If N<0 Then
  223.     N:=0;
  224.    S[0]:=Chr(N);
  225.    FillChar(S[1],N,C);
  226.    ConstStr:=S;
  227.   End;
  228.  
  229.   {  Beep sounds the terminal bell or beeper }
  230.  
  231.  Procedure Beep;
  232.   Begin
  233.    Write(BEEP_Key);
  234.   End;
  235.  
  236.  
  237.  Procedure InputStr(Var S:Str255;
  238.                     L,x,y:Integer;
  239.                     Term:CharSet;
  240.                     Var TC:Char);
  241.   Var
  242.    P:Integer;
  243.    ch:Char;
  244.    Special:Boolean;
  245.    InsertMode:Boolean;
  246.   Begin
  247.    NormVideo;
  248.    If Length(S)>L Then
  249.     S:=Copy(S,1,L);
  250.    GoToXY(x,y);Write(S,ConstStr('_',L-Length(S)));
  251.    InsertMode:=True;
  252.    P:=0;
  253.    Repeat
  254.     GoToXY(x+P,y);ch:=Read_Char(Special);
  255.     If Not Special Then
  256.      Begin
  257.       Case ch Of
  258.        #32..#126:If P<L Then
  259.                   Begin
  260.                    Case InsertMode Of
  261.                     True:Begin
  262.                           If Length(S)=L Then
  263.                            Delete(S,L,1);
  264.                           P:=P+1;
  265.                           Insert(ch,S,P);
  266.                           Write(Copy(S,P,L));
  267.                           If P=L Then P:=P-1;
  268.                          End;
  269.                     False:Begin
  270.                            P:=P+1;
  271.                            If P<=Length(S) Then
  272.                             Delete(S,P,1);
  273.                            Insert(ch,S,P);
  274.                            Write(Copy(S,P,L));
  275.                            If P=L Then P:=P-1;
  276.                           End;
  277.                    End;                     { case Insert Mode }
  278.                   End;
  279.  
  280.        BACKSPACE_Key:If P>0 Then
  281.                       Begin
  282.                        Delete(S,P,1);
  283.                        Write(BACKSPACE_Key,Copy(S,P,L),'_':1);
  284.                        P:=P-1;
  285.                       End
  286.                      Else Beep;
  287.       Else
  288.        If Not(ch In Term) Then Beep;
  289.       End;                                  { of case }
  290.      End
  291.     Else
  292.      Begin
  293.       Case ch Of
  294.        LEFT_Key:If P>0 Then
  295.                  P:=P-1
  296.                 Else Beep;
  297.        RIGHT_Key:If P<Length(S) Then
  298.                   P:=P+1
  299.                  Else Beep;
  300.        INSERT_Key:InsertMode:=Not InsertMode;
  301.        HOME_Key:P:=0;
  302.        END_Key:P:=Length(S);
  303.        DELETE_Key:If P<Length(S) Then
  304.                    Begin
  305.                     Delete(S,P+1,1);
  306.                     Write(Copy(S,P+1,L),'_':1);
  307.                    End;
  308.        CTRL_END_Key:Begin
  309.                      Write(ConstStr('_',Length(S)-P));
  310.                      Delete(S,P+1,L);
  311.                     End;
  312.       Else
  313.        Beep;
  314.       End;                                  {of case}
  315.      End;
  316.    Until ch In Term;
  317.    P:=Length(S);
  318.    GoToXY(x+P,y);
  319.    If L>P Then Write(ConstStr('_',L-P));
  320.    TC:=ch;
  321.    LowVideo;
  322.   End;
  323.  
  324.  
  325.  Procedure Select(Prompt:Str80;
  326.                   Term:CharSet;
  327.                   Var TC:Char);
  328.   Var
  329.    ch:Char;
  330.    Special:Boolean;
  331.   Begin
  332.    GoToXY(1,23);Write(Prompt,'? ');ClrEol;
  333.    Repeat
  334.     ch:=Read_Char(Special);
  335.     TC:=UpCase(ch);
  336.     If Not(TC In Term) Then
  337.      Beep;
  338.    Until TC In Term;
  339.    Case ch Of
  340.     #32..#126:Write(TC);
  341.    End;
  342.   End;
  343.  
  344.  Procedure ClearLines(F,L:Integer);
  345.   Var
  346.    I:Integer;
  347.   Begin
  348.    For I:=F To L Do
  349.     Begin
  350.      GoToXY(1,I);ClrEol;
  351.     End;
  352.   End;
  353.  
  354.  
  355.   {*Include File End INPUTUTI.INC ***** END *****}
  356.   {*Include File     MESSAGE.INC ***** START *****}
  357.  Procedure Message(S:Str80);
  358.   Begin
  359.    GoToXY(1,25);ClrEol;
  360.    If Length(S)>0 Then
  361.     Begin
  362.      NormVideo;
  363.      Write('ERROR: ',S);
  364.      LowVideo;
  365.      Beep;
  366.     End;
  367.   End;
  368.  
  369.   {*Include File End MESSAGE.INC ***** END *****}
  370.   {*Include File     BIOSDATE.INC ***** START *****}
  371.  Type
  372.   Bios=Record
  373.         ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer;
  374.        End;
  375.  
  376.   BiosB=Record
  377.          al,ah,bl,bh,cl,ch,dl,dh:Byte;
  378.         End;
  379.  
  380.  
  381.  Procedure GetDate(Var Year,Month,Day:Integer);
  382.   Var
  383.    Reg:Bios;
  384.    RegB:BiosB Absolute Reg;
  385.  
  386.   Begin
  387.    RegB.ah:=$2A;
  388.    MsDos(Reg);
  389.    Year:=Reg.cx;
  390.    Month:=RegB.dh;
  391.    Day:=RegB.dl;
  392.   End;
  393.  
  394.  Procedure GetTime(Var Hrs,Min,Sec,HSec:Integer);
  395.   Var
  396.    Reg:Bios;
  397.    RegB:BiosB Absolute Reg;
  398.  
  399.   Begin
  400.    RegB.ah:=$2C;
  401.    MsDos(Reg);
  402.    Hrs:=RegB.ch;
  403.    Min:=RegB.cl;
  404.    Sec:=RegB.dh;
  405.    HSec:=RegB.dl;
  406.   End;
  407.  
  408.  
  409.   {*Include File End BIOSDATE.INC ***** END *****}
  410.   {*Include File     GETSWITC.INC ***** START *****}
  411.   { **************************************************************************
  412.   WARNING !  WARNING  ! WARNING ! WARNING ! WARNING ! WARNING ! WARNING !
  413.   -----------------------------------------------------------------------
  414.  
  415.   This function call is defined in the Program Development Guide on the
  416.   WANG system.  This function returns the switch character used by
  417.   COMMAND.COM.  On the WANG system this is '-', to try to make this
  418.   program generic I used this call.  In the IBM DOS Technical Ref 2.10
  419.   this call was documented only by the line 'USED INTERNALLY'. If this
  420.   does not work change this function to return your switch char which
  421.   is probably '/' if you are on an IBM/IBM clone.
  422.  
  423.   }
  424.  
  425.  Function GetDOSswitch:Char;
  426.   Type
  427.    DosRegs=Record Case Integer Of
  428.     1:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  429.     2:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  430.            End;
  431.   Var
  432.    Regs:DosRegs;
  433.   Begin
  434.    With Regs Do
  435.     Begin
  436.      ah:=$37;
  437.      al:=0;
  438.     End;
  439.    MsDos(Regs);
  440.    With Regs Do
  441.     GetDOSswitch:=Chr(dl);
  442.   End;
  443.  
  444.  
  445.   {*Include File End GETSWITC.INC ***** END *****}
  446.   {*Include File     FILLZERO.INC ***** START *****}
  447.  Procedure FillZero(Var S:Str255);
  448.   Var
  449.    I:Integer;
  450.   Begin
  451.    For I:=1 To Length(S) Do
  452.     If S[I]=' ' Then
  453.      S[I]:='0';
  454.   End;
  455.  
  456.   {*Include File End FILLZERO.INC ***** END *****}
  457.   {*Include File     SPFUN.INC ***** START *****}
  458.   { these routines use the MSDOS functions to get the date and time.  The
  459.   data is then converted into printable format. }
  460.  
  461.  Function CurrentDate:Str80;
  462.   Var
  463.    Month,
  464.    Day,
  465.    Year:Integer;
  466.    S,T:Str255;
  467.  
  468.   Begin
  469.    GetDate(Year,Month,Day);
  470.    Str(Month:2,S);
  471.    FillZero(S);
  472.    T:=S+'/';
  473.    Str(Day:2,S);
  474.    FillZero(S);
  475.    T:=T+S+'/';
  476.    Str(Year,S);
  477.    T:=T+S;
  478.    CurrentDate:=T;
  479.   End;
  480.  
  481.  Function Time:Str80;
  482.   Var
  483.    Hrs,
  484.    Min,
  485.    Sec,
  486.    HSec:Integer;
  487.    S,T:Str255;
  488.  
  489.   Begin
  490.    GetTime(Hrs,Min,Sec,HSec);
  491.    If Hrs>12 Then Str(Hrs-12:2,S)
  492.    Else Str(Hrs:2,S);
  493.    FillZero(S);
  494.    T:=S+':';
  495.    Str(Min:2,S);
  496.    FillZero(S);
  497.    T:=T+S+':';
  498.    Str(Sec:2,S);
  499.    FillZero(S);
  500.    T:=T+S;
  501.    If (Hrs=12) And (Min=0) Then T:=T+'  M' Else
  502.    If Hrs<12 Then T:=T+' AM' Else
  503.     T:=T+' PM';
  504.    Time:=T;
  505.   End;
  506.  
  507.   {*Include File End SPFUN.INC ***** END *****}
  508.   {*Include File     EXEC16.INC ***** START *****}
  509.   { EXEC.PAS version 1.6
  510.   Copyright (C) 1986 by Bela Lubkin  (1/21/86)
  511.   Noncommercial use only EXCEPT with permission from Bela Lubkin; send
  512.   EasyPlex to CompuServe ID 76703,3015 for permission.
  513.  
  514.   See "VERY IMPORTANT NOTES" below before using these functions.  This is
  515.   especially important if you are using Turbo version 1.0 or 2.0.
  516.  
  517.   Allows you to
  518.   o Call MS-DOS programs
  519.   o Get the return codes from those programs
  520.   o Get strings from the MS-DOS environment
  521.  
  522.   Calling information
  523.   -------------------
  524.   Procedure FreeUpMemory;
  525.   This procedure calls MS-DOS to free up memory that is not used by the
  526.   running program.  It is needed only under Turbo 1.0 or 2.0.  It is
  527.   commented out in this file.  Uncomment it only if you are using a pre-
  528.   3.0 version of Turbo Pascal.  It must be called once and ONLY ONCE
  529.   before calling any of SubProcess, SubProcessViaCOMMAND, or Shell.  It is
  530.   a good idea to place this call early in the execution of the program.
  531.  
  532.   Function SubProcess(CommandLine: _Exec_Str255): Integer;
  533.   Calls an executable image (.COM or .EXE file) using MS-DOS function
  534.   4Bh, Exec.  The parameter CommandLine must contain both the name of the
  535.   program to run and the arguments to be passed to it, seperated by a
  536.   space.  Path searching and other amenities are not performed; the passed
  537.   in name must be specific enough to allow the file to be found, i.e.
  538.   'CHKDSK' will NOT work.  At least 'CHKDSK.COM' must be specified, and a
  539.   drive and path name will help even more.  For example,
  540.   'C:\SYSTEM\CHKDSK.COM'
  541.   'A:\WS.COM DOCUMENT.1'
  542.   'C:\DOS\LINK.EXE TEST;'
  543.   'D:\ASSEM\MASM.EXE PROG1 PROG1.OBJ NUL PROG1.MAP'
  544.   'C:\COMMAND.COM /C COPY *.* B:\BACKUP >FILESCOP.IED'
  545.   The last example uses COMMAND.COM to invoke a DOS internal command and
  546.   to perform redirection.  Only with the use of COMMAND.COM can the
  547.   following be done: redirection; piping; path searching; searching for
  548.   the extension of a program (.COM, .EXE, or .BAT); batch files; and
  549.   internal DOS commands.
  550.   Because the COMMAND-assisted Exec function is so useful, a seperate
  551.   function, SubProcessViaCOMMAND, is provided for that purpose.
  552.   The integer return value of SubProcess is the error value returned by
  553.   DOS on completion of the Exec call.  If it is nonzero, the call failed.
  554.   Here is a list of likely error values:
  555.   0: Success
  556.   2: File/path not found
  557.   3: Path not found
  558.   4: Too many files open (no handles left)
  559.   5: Access denied
  560.   8: Not enough memory to load program
  561.   10: Illegal environment (greater than 32K)
  562.   11: Illegal .EXE file format
  563.   32: Sharing violation
  564.   33: Lock violation
  565.   If you get any other result, consult an MS-DOS Technical Reference
  566.   manual.
  567.  
  568.   Function GetEnvStr(SearchString: _Exec_Str255): _Exec_Str255;
  569.   Gets a string from the MS-DOS environment.  The parameter SearchString
  570.   specifies the desired environment string.  The function result returns
  571.   the value of that string from the environment.  If the string is not
  572.   found, a null string is returned.  SearchString may have one special
  573.   value, '='.  This returns garbage under MS-DOS 2.x.  Under MS-DOS 3.x,
  574.   it returns the pathname under which the currently running program was
  575.   invoked.  Examples:
  576.   GetEnvStr('COMSPEC')   might = 'C:\COMMAND.COM'
  577.   GetEnvStr('PROMPT')    might = '$p $g'
  578.   GetEnvStr('REFLEX')    might = 'Herc'
  579.   GetEnvStr('=')         might = 'C:\TURBO\exectest.COM'
  580.   Only an exact match will succeed; case IS significant.  Do not include
  581.   an equal sign in the search string (GetEnvStr('COMSPEC=') will fail).
  582.   Note: if you are wondering why there is no SetEnvStr procedure, read
  583.   an MS-DOS Technical Reference manual.
  584.  
  585.   Function GetComSpec: _Exec_Str66;
  586.   This is a special case of GetEnvStr and simply returns the COMSPEC
  587.   environment string.  It is included for compatability with previous
  588.   EXEC.PAS versions.
  589.  
  590.   Function SubProcessViaCOMMAND(CommandLine: _Exec_Str255): Integer;
  591.   This is a special case of SubProcess.  The CommandLine is passed to
  592.   COMMAND.COM, which does all further processing.  Command lines invoked
  593.   via this function can do redirection and piping; undergo the normal DOS
  594.   PATH search; may be batch files; and may be internal DOS commands such
  595.   as COPY and RENAME.
  596.   Disadvantages of this approach are: a copy of COMMAND.COM must be
  597.   present (not always true on a floppy-based system); a slight time and
  598.   memory penalty is involved due to the loading of an extra copy of
  599.   COMMAND.COM (about 3K under DOS 3.1); the subprocess return code
  600.   (Errorlevel) is lost.  In most cases the benefits will outweight the
  601.   disadvantages.
  602.   The integer return code is the same as for SubProcess.
  603.   Note: you may be wondering why there is not
  604.  
  605.   Function Shell: Integer;
  606.   This is a special case of SubProcess.  It gives a DOS prompt to the
  607.   user.  Typing EXIT returns to the Turbo program.  The integer return
  608.   code is the same as for SubProcess.
  609.  
  610.   Function SubProcessReturnCode: Integer;
  611.   This function calls MS-DOS function 4Dh, Get Return Code of a
  612.   Sub-process.  The integer return value is the return code set by the
  613.   last subprocess you called.  Like Turbo's IOResult, SubProcessReturnCode
  614.   is only valid once after a SubProcess call, reverting to 0 on successive
  615.   calls.  The return code obtained after using SubProcessViaCOMMAND or
  616.   Shell is the code returned by COMMAND.COM, not by any other program, and
  617.   is not likely to be useful.
  618.   Note: Turbo 3.0 programs can set the return code by using the Halt
  619.   procedure with a parameter, e.g. Halt(20);.  Other languages can call
  620.   DOS function 4Ch (Terminate) with the return code in AL.  Use Inline
  621.   code or the MsDos procedure under Turbo 1.0 or 2.0.
  622.  
  623.   VERY IMPORTANT NOTES
  624.   --------------------
  625.   The Exec calls (SubProcess, SubProcessViaCOMMAND, Shell) will not work
  626.   unless you restrict Turbo's heap.  To do this, lower "mAximum dynamic free
  627.   memory" on the compiler Options menu to a reasonable value.  What is
  628.   reasonable depends on your program's use of the heap and the stack, and must
  629.   be determined by you.  If you use neither the heap nor recursion, as low as
  630.   400h (16K bytes) is probably more than enough.
  631.  
  632.   The Exec calls CANNOT be called from within the interactive Turbo compiler
  633.   system.  They can only be called from .COM or .CHN files running outside of
  634.   the Turbo environment.
  635.  
  636.   If you are using Turbo 1.0 or 2.0, you must call FreeUpMemory once and ONLY
  637.   ONCE before making any calls to SubProcess, SubProcessViaCOMMAND, or Shell.
  638.   Uncomment the FreeUpMemory procedure, remove the Exit statement from
  639.   SubProcess, and make sure you call FreeUpMemory before attempting to do any
  640.   Exec calls!!
  641.  
  642.   Revision history
  643.   ----------------
  644.   Version 1.6 1/21/86 re-adds support for Turbo 1.0, 2.0 by providing the
  645.   procedure FreeUpMemory.  Adds the Shell function that was
  646.   inadvertantly left out of 1.5.
  647.   Version 1.5 1/14/86 fixes the memory freeing bug by removing support for
  648.   Turbo 2.0.  String types changed to minimize chances of
  649.   collision.  General environment support added.  Explicit calls
  650.   for Exec-via-COMMAND.COM and Exec-to-DOS-prompt added.  Support
  651.   for getting the subprocess return code added.  Major
  652.   documentation overhaul.  NOW REQUIRES TURBO 3.0!
  653.   (Thanks to Stu Fuller 76703,501 for pointing out how easy it
  654.   was to add full environment support).
  655.   Version 1.4 attempts to fix a bug in the freeing of memory before the
  656.   Exec call.
  657.   Version 1.3 works with MS-DOS 2.0 and up, TURBO PASCAL version 1.0 and up.
  658.   Version 1.2 had a subtle but dangerous bug: I set a variable that was
  659.   addressed relative to BP, using a destroyed BP!
  660.   Version 1.1 didn't work with Turbo 2.0 because I used Turbo 3.0 features
  661.   Version 1.0 only worked with DOS 3.0 due to a subtle bug in DOS 2.x
  662.  
  663.   -  Bela Lubkin
  664.   CompuServe 76703,3015
  665.   }
  666.  
  667.  Type
  668.   _Exec_Str66=String[66];
  669.   _Exec_Str255=String[255];
  670.  
  671.  Var
  672.   _Exec_Regs:Record Case Integer Of
  673.    1:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  674.    2:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  675.              End;
  676.   { NOTE: the above variable is referenced in an Inline statement.  It MUST
  677.   be a global variable (not a local variable or a typed constant)!! }
  678.  
  679.   (* THIS PROCEDURE MUST BE CALLED ONCE AND ONLY ONCE, BEFORE ANY CALLS TO THE
  680.   SUBPROCESS PROCEDURES, AND ONLY IF TURBO 1.0 OR 2.0 IS BEING USED!!!!!!!!
  681.   Uncomment it only if necessary.
  682.  
  683.   Procedure FreeUpMemory;
  684.   { Paraphrases part of Turbo 3.0's startup code:
  685.   (CS:[101h]+106h) is the address of the compiler Options.
  686.   Options[6] is the code segment size the program (paragraphs).
  687.   Options[8] is the data segment size.
  688.   (CS+Options[6]+Options[8]) is the highwater mark of the program, sans
  689.   stack/heap.
  690.   CS:[2] is supplied by DOS: the number of paragraphs available to the
  691.   program.
  692.   (CS:[2]-High water mark) is the number of paragraphs available to the
  693.   stack/heap.
  694.   Options[0Ch] is the maximum stack/heap size needed by the program.
  695.   The heap size is taken as the lesser of Options[0Ch] and
  696.   (CS:[2]-highwater mark).
  697.   The highwater mark including the stack/heap is the no-heap highwater
  698.   mark + the calculated heap size.
  699.   The size in paragraphs of the program, including code, data, stack and
  700.   heap, is the full highwater mark - the original CS.
  701.   DOS function 4Ah, Set memory block, is called to adjust the size of the
  702.   program's memory block to the calculated size of the entire program. }
  703.   Begin
  704.    InLine(
  705.    $2E/$8B/$36/$01/$01/     {     ADD SI,106h         }
  706.    $81/$C6/$06/$01/         {     ADD SI,106h         }
  707.    $8C/$CB/                 {     MOV BX,CS           }
  708.    $2E/$03/$5C/$06/         {     ADD BX,CS:[SI+6]    }
  709.    $2E/$03/$5C/$08/         {     ADD BX,CS:[SI+8]    }
  710.    $2E/$8B/$16/$02/$00/     {     MOV DX,CS:[2]       }
  711.    $29/$DA/                 {     SUB DX,BX           }
  712.    $2E/$3B/$54/$0C/         {     CMP DX,CS:[SI+0Ch]  }
  713.    $72/$04/                 {     JB  .1              }
  714.    $2E/$8B/$54/$0C/         {     MOV DX,CS:[SI+0Ch]  }
  715.    $8C/$C8/                 { .1: MOV AX,CS           }
  716.    $8E/$C0/                 {     MOV ES,AX           }
  717.    $01/$D3/                 {     ADD BX,DX           }
  718.    $2B/$D8/                 {     SUB BX,AX           }
  719.    $B4/$4A/                 {     MOV AH,4Ah          }
  720.    $CD/$21);                {     INT 21h             }
  721.   End; *)
  722.  
  723.  Function SubProcess(CommandLine:_Exec_Str255):Integer;
  724.   Const
  725.    SSSave:Integer=0;
  726.    SPSave:Integer=0;
  727.  
  728.   Var
  729.    FCB1,FCB2:Array[0..36] Of Byte;          {*}
  730.    PathName:_Exec_Str66;                    {*}
  731.    CommandTail:_Exec_Str255;
  732.    ParmTable:Record                         {*}
  733.               EnvSeg:Integer;
  734.               ComLin:^Integer;
  735.               FCB1Pr:^Integer;
  736.               FCB2Pr:^Integer;
  737.              End;
  738.    RegsFlags:Integer;                       {*}
  739.    {*: these variables are accessed in an Inline statement; their
  740.    declarations must not be changed }
  741.  
  742.   Begin
  743.    If Pos(' ',CommandLine)=0 Then
  744.     Begin
  745.      PathName:=CommandLine+#0;
  746.      CommandTail:=^M;
  747.     End
  748.    Else
  749.     Begin
  750.      PathName:=Copy(CommandLine,1,Pred(Pos(' ',CommandLine)))+#0;
  751.      CommandTail:=Copy(CommandLine,Pos(' ',CommandLine),255)+^M;
  752.     End;
  753.    CommandTail[0]:=Pred(CommandTail[0]);
  754.    With _Exec_Regs Do
  755.     Begin
  756.      FillChar(FCB1,SizeOf(FCB1),0);
  757.      ax:=$2901;
  758.      ds:=Seg(CommandTail[1]);
  759.      si:=Ofs(CommandTail[1]);
  760.      es:=Seg(FCB1);
  761.      di:=Ofs(FCB1);
  762.      MsDos(_Exec_Regs);                     { Create FCB 1 }
  763.      FillChar(FCB2,SizeOf(FCB2),0);
  764.      ax:=$2901;
  765.      es:=Seg(FCB2);
  766.      di:=Ofs(FCB2);
  767.      MsDos(_Exec_Regs);                     { Create FCB 2 }
  768.      With ParmTable Do
  769.       Begin
  770.        EnvSeg:=MemW[CSeg:$002C];
  771.        ComLin:=Addr(CommandTail);
  772.        FCB1Pr:=Addr(FCB1);
  773.        FCB2Pr:=Addr(FCB2);
  774.       End;
  775.      Inline($8D/$96/PathName/$42/           { <DX>:=Ofs(PathName[1]); }
  776.       $8D/$9E/ParmTable/                    { <BX>:=Ofs(ParmTable);   }
  777.       $B8/$00/$4B/                          { <AX>:=$4B00;            }
  778.       $1E/$55/                              { Save <DS>, <BP>         }
  779.       $16/$1F/                              { <DS>:=Seg(PathName[1]); }
  780.       $16/$07/                              { <ES>:=Seg(ParmTable);   }
  781.       $2E/$8C/$16/SSSave/                   { Save <SS> in SSSave     }
  782.       $2E/$89/$26/SPSave/                   { Save <SP> in SPSave     }
  783.       $FA/                                  { Disable interrupts      }
  784.       $CD/$21/                              { Call MS-DOS             }
  785.       $FA/                                  { Disable interrupts      }
  786.       $2E/$8B/$26/SPSave/                   { Restore <SP>            }
  787.       $2E/$8E/$16/SSSave/                   { Restore <SS>            }
  788.       $FB/                                  { Enable interrupts       }
  789.       $5D/$1F/                              { Restore <BP>,<DS>       }
  790.       $9C/$8F/$86/RegsFlags/                { Flags:=<CPU flags>      }
  791.       $A3/_Exec_Regs);                      { _Exec_Regs.AX:=<AX>;    }
  792.      { The messing around with SS and SP is necessary because under DOS 2.x,
  793.      after returning from an EXEC call, ALL registers are destroyed except
  794.      CS and IP!  I wish I'd known that before I released this package the
  795.      first time... }
  796.      If (RegsFlags And 1)<>0 Then SubProcess:=ax
  797.      Else SubProcess:=0;
  798.     End;
  799.    Exit;                                    { This line is here for one reason only: to cause compilation to
  800.                                             fail under Turbo 1.0 or 2.0 and force you to read this comment.
  801.                                             Go back and read the VERY IMPORTANT NOTES section.  Then comment
  802.                                             out this Exit, uncomment Procedure FreeUpMemory, and add a call to
  803.                                             it to your code before attempting any calls to any of the Exec
  804.                                             functions!! }
  805.   End;
  806.  
  807.  Function GetEnvStr(SearchString:_Exec_Str255):_Exec_Str255;
  808.   Type
  809.    Env=Array[0..32767] Of Char;
  810.   Var
  811.    EPtr:^Env;
  812.    EStr:_Exec_Str255;
  813.    Done:Boolean;
  814.    I:Integer;
  815.  
  816.   Begin
  817.    GetEnvStr:='';
  818.    If SearchString<>'' Then
  819.     Begin
  820.      EPtr:=Ptr(MemW[CSeg:$002C],0);
  821.      I:=0;
  822.      SearchString:=SearchString+'=';
  823.      Done:=False;
  824.      EStr:='';
  825.      Repeat
  826.       If EPtr^[I]=#0 Then
  827.        Begin
  828.         If EPtr^[Succ(I)]=#0 Then
  829.          Begin
  830.           Done:=True;
  831.           If SearchString='==' Then
  832.            Begin
  833.             EStr:='';
  834.             I:=I+4;
  835.             While EPtr^[I]<>#0 Do
  836.              Begin
  837.               EStr:=EStr+EPtr^[I];
  838.               I:=Succ(I);
  839.              End;
  840.             GetEnvStr:=EStr;
  841.            End;
  842.          End;
  843.         If Copy(EStr,1,Length(SearchString))=SearchString Then
  844.          Begin
  845.           GetEnvStr:=Copy(EStr,Succ(Length(SearchString)),255);
  846.           Done:=True;
  847.          End;
  848.         EStr:='';
  849.        End
  850.       Else EStr:=EStr+EPtr^[I];
  851.       I:=Succ(I);
  852.      Until Done;
  853.     End;
  854.   End;
  855.  
  856.  Function GetComSpec:_Exec_Str66;
  857.   Begin
  858.    GetComSpec:=GetEnvStr('COMSPEC');
  859.   End;
  860.  
  861.  Function SubProcessViaCOMMAND(CommandLine:_Exec_Str255):Integer;
  862.   Begin
  863.    SubProcessViaCOMMAND:=SubProcess(GetComSpec+' /C '+CommandLine);
  864.   End;
  865.  
  866.  Function Shell:Integer;
  867.   Begin
  868.    Shell:=SubProcess(GetComSpec);
  869.   End;
  870.  
  871.  Function SubProcessReturnCode:Integer;
  872.   Begin
  873.    _Exec_Regs.ah:=$4D;
  874.    MsDos(_Exec_Regs);
  875.    SubProcessReturnCode:=_Exec_Regs.ax;
  876.   End;
  877.  
  878.  
  879.   {*Include File End EXEC16.INC ***** END *****}
  880.   {*Include File     SRCHPATH.INC ***** START *****}
  881.   { File PATH.INC from DL1 of Borland SIG.  Author is Jack Zucker              }
  882.  
  883.   (*
  884.   ZDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD?
  885.   3 This function returns substring n based on a string of data delimited by a  3
  886.   3 particular character of your choice.                                        3
  887.   3 Arguments:                                                                  3
  888.   3   A          : Your string of data with delimiters                          3
  889.   3   Delimiter  : Your choice of character to use as a delimiter               3
  890.   3   Piece      : The number of the "piece" in the string to return            3
  891.   3   RestOfStr  : If True it returns the "piece" Piece through the end of the  3
  892.   3                str. If false the function returns just the "piece" piece    3
  893.   3                you asked for.                                               3
  894.   3   Ex.        : S := 'Jack Zucker;10318 Broom Lane;Seabrook;Md;20706'        3
  895.   3                 GetPiece(S,';',3,False) would return 'Seabrook'             3
  896.   @DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDY
  897.   *)
  898.  
  899.  Function GetPiece(A:Str255;Delimiter:Char;Piece:Byte;
  900.                    RestOfStr:Boolean):Str255;
  901.   Var
  902.    Temp:Str255;
  903.    I,J:Integer;
  904.    ch:Char;
  905.  
  906.   Begin
  907.    J:=1;
  908.    I:=1;
  909.    Temp:=A;
  910.    While (I<Length(A)+1) And (J<Piece) Do Begin
  911.     If A[I]=Delimiter Then
  912.      Begin
  913.       Temp:=Copy(A,I+1,255);
  914.       J:=J+1;
  915.      End;
  916.     I:=I+1;
  917.    End;
  918.    I:=Pos(Delimiter,Temp);
  919.    If J=Piece Then
  920.     Begin
  921.      If I>0 Then If RestOfStr Then GetPiece:=Temp
  922.      Else GetPiece:=Copy(Temp,1,I-1)
  923.     Else If Temp<>A Then GetPiece:=Temp;
  924.     End
  925.    Else GetPiece:='';
  926.    If (Pos(Delimiter,A)=0) And (Piece=1) Then GetPiece:=A;
  927.   End;
  928.  
  929.   (*
  930.   ZDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD?
  931.   3This routine gets the current path. It returns a string with all the paths   3
  932.   3and it's your job to do something with them. It is the copy of the dos path  3
  933.   3so see your dos manual if you have any questions about paths.                3
  934.   3The function is of the type Str255 which fits any string and is declared as  3
  935.   3Str255 = String[255];                                                        3
  936.   @DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDY
  937.   *)
  938.  
  939.  Function GetPath:Str255;
  940.   Var
  941.    P:^Byte;
  942.    S:Str255;
  943.    I:Integer;
  944.   Begin
  945.    P:=Ptr(MemW[CSeg:$2C],0);                { Point to the Dos Comspec }
  946.    Move(P^,S[1],255);                       { Move it to the string S  }
  947.    S[0]:=#$FF;
  948.    I:=Pos('PATH=',S);
  949.    If I=0 Then GetPath:=''
  950.    Else
  951.     Begin
  952.      S:=Copy(S,I+5,$FF);                    { Move String[1] past the word "PATH=" }
  953.      S:=Copy(S,1,Pos(#0,S)-1);              { Dos uses Null char to terminate Strings}
  954.      GetPath:=S;
  955.     End;
  956.   End;
  957.  
  958.   (*
  959.   ZDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD?
  960.   3This function will find a file by looking through all the dos path specs     3
  961.   3until it either finds the file or the paths are exhausted. It will return    3
  962.   3either the path that the file is found in or '' if the file is not in any    3
  963.   3of the dos paths. It calls the routine getpath which reads in the dos path.  3
  964.   3It takes as it's argument, the name of the file for which it is looking.     3
  965.   @DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDY
  966.   *)
  967.  
  968.  Function FindFile(FName:Str255):Str255;
  969.   Var
  970.    I:Byte;
  971.    Fd:File;
  972.    FullPath,
  973.    Path:Str255;
  974.   Begin
  975.    I:=0;
  976.    FullPath:=GetPath;
  977.    GetDir(0,Path);
  978.    While Path<>'' Do
  979.     Begin
  980.      If Not(Path[Length(Path)]='\') Then
  981.       Path:=Path+'\';
  982.      Assign(Fd,Path+FName);
  983.      {$I-}
  984.      Reset(Fd);
  985.      {$I+}
  986.      If IOResult=0 Then
  987.       Begin
  988.        FindFile:=Path;
  989.        Close(Fd);
  990.        Exit;
  991.       End
  992.      Else
  993.       Begin
  994.        Close(Fd);
  995.        I:=I+1;
  996.        Path:=GetPiece(FullPath,';',I,False);
  997.       End;
  998.     End;
  999.    FindFile:='';
  1000.   End;
  1001.  
  1002.   {*Include File End SRCHPATH.INC ***** END *****}
  1003.   {*Include File     CURDRIVE.INC ***** START *****}
  1004.  Procedure CurrentDrive(Var S:Str2);
  1005.   Type
  1006.    DosRegs=Record Case Integer Of
  1007.     1:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  1008.     2:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  1009.            End;
  1010.   Var
  1011.    Regs:DosRegs;
  1012.   Begin
  1013.    Regs.ah:=$19;                            { Current Disk function code }
  1014.    MsDos(Regs);                             { do it , close your eyes    }
  1015.    S:=Chr(Ord('A')+Regs.al)+':';            { Generate drive designation }
  1016.   End;
  1017.  
  1018.  
  1019.   {*Include File End CURDRIVE.INC ***** END *****}
  1020.   {*Include File     MENUTYPE.INC ***** START *****}
  1021.  Type
  1022.   bytechar=Record Case Boolean Of
  1023.    True:(C:Char);
  1024.    False:(b:Byte);
  1025.            End;
  1026.   MenuPointer=^MenuBuffer;
  1027.   MenuBuffer=Record
  1028.               Buf:Array[1..5,0..255] Of bytechar;
  1029.              End;
  1030.   HelpPointer=^HelpBuffer;
  1031.   HelpBuffer=Record
  1032.               Buf:Array[1..187,0..255] Of bytechar;
  1033.              End;
  1034.  
  1035.   ByteFile=File;
  1036.  
  1037.  Const
  1038.   Special:Set Of Char=[#$09,#$08,#$0D,#$20,ESCAPE_Key];
  1039.  
  1040.  Var
  1041.   HBuffer:HelpBuffer;
  1042.   MBuffer:MenuBuffer;
  1043.   FilVar:ByteFile;
  1044.  
  1045.   {*Include File End MENUTYPE.INC ***** END *****}
  1046.   {*Include File     HANDLE.INC ***** START *****}
  1047.   {  The Following functions were written to take care of the ReadBlock
  1048.   bug in Turbo V3.0.  The FileHandle function returns the MSDOS file
  1049.   handle to be used in reading from a file.  The DosBlockRead function
  1050.   will attempt to read Recs number of bytes from a file with handle
  1051.   FileH.  If no error occurs then the number of bytes read will be
  1052.   return in Result, otherwise Result will be -1.
  1053.  
  1054.   Gary W. Miller
  1055.   70127,3674    Compuserve
  1056.  
  1057.   }
  1058.  
  1059.  Function FileHandle(Var FilVar):Integer;
  1060.   Var
  1061.    H:Integer Absolute FilVar;
  1062.   Begin
  1063.    FileHandle:=H;
  1064.   End;
  1065.  
  1066.  
  1067.  Procedure DosBlockRead(FileH:Integer;Var buffer;Recs:Integer;Var Result:Integer);
  1068.   Type
  1069.    DosRegs=Record Case Integer Of
  1070.     1:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  1071.     2:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  1072.            End;
  1073.   Var
  1074.    Regs:DosRegs;
  1075.   Begin
  1076.    With Regs Do
  1077.     Begin
  1078.      ds:=Seg(buffer);                       { location of Buffer segment }
  1079.      dx:=Ofs(buffer);                       {                    offset  }
  1080.      cx:=Recs;                              { number of bytes to read    }
  1081.      ah:=$3f;                               { Read File or Device Code   }
  1082.      bx:=FileH;                             { Pass file handle           }
  1083.     End;
  1084.    MsDos(Regs);                             { do it , close your eyes    }
  1085.    With Regs Do
  1086.     Begin
  1087.      If (flags And 1)<>0 Then
  1088.       Result:=-1                            { crap, we blew it           }
  1089.      Else
  1090.       Result:=ax;                           { tell me what you read      }
  1091.     End;
  1092.   End;
  1093.  
  1094.  
  1095.  Procedure DosBlockWrite(FileH:Integer;Var buffer;Recs:Integer;Var Result:Integer);
  1096.   Type
  1097.    DosRegs=Record Case Integer Of
  1098.     1:(ax,bx,cx,dx,bp,si,di,ds,es,flags:Integer);
  1099.     2:(al,ah,bl,bh,cl,ch,dl,dh:Byte);
  1100.            End;
  1101.   Var
  1102.    Regs:DosRegs;
  1103.   Begin
  1104.    With Regs Do
  1105.     Begin
  1106.      ds:=Seg(buffer);                       { location of Buffer segment }
  1107.      dx:=Ofs(buffer);                       {                    offset  }
  1108.      cx:=Recs;                              { number of bytes to write   }
  1109.      ah:=$40;                               { Write File or Device Code  }
  1110.      bx:=FileH;                             { Pass file handle           }
  1111.     End;
  1112.    MsDos(Regs);                             { do it , close your eyes    }
  1113.    With Regs Do
  1114.     Begin
  1115.      If (flags And 1)<>0 Then
  1116.       Result:=-1                            { crap, we blew it           }
  1117.      Else
  1118.       Result:=ax;                           { tell me what you wrote     }
  1119.     End;
  1120.   End;
  1121.  
  1122.  
  1123.   {*Include File End HANDLE.INC ***** END *****}
  1124.   {*Include File     CHGDIR.INC ***** START *****}
  1125.   { This procedure changes the current logged directory or drive based
  1126.   on the string passed.  To change the logged drive pass this function
  1127.   the drive you wish to change to.  To change directory pass the complete
  1128.   path name of the directory to change to.  If any error occurs while
  1129.   making the change an error flag will be returned. }
  1130.  
  1131.  Procedure CurrentDirectory(Var S:Str255);
  1132.   Begin
  1133.    GetDir(0,S);
  1134.    S:=Copy(S,Pos(':',S)+1,Length(S));
  1135.   End;
  1136.  
  1137.  Procedure ChangeDir(S:Str255;Var Ok:Boolean);
  1138.   Begin
  1139.    {$I-}
  1140.    ChDir(S);
  1141.    {$I+}
  1142.    Ok:=(IOResult=0);
  1143.   End;
  1144.  
  1145.   { This procedure makes the rather rash assumtion that what ever path you
  1146.   pass it exists.  If it does not exist then the function will return
  1147.   without doing anything. }
  1148.  
  1149.  Procedure ReturnToPath(S:Str255);
  1150.   Var
  1151.    Ok:Boolean;
  1152.  
  1153.   Begin
  1154.    ChangeDir(S,Ok);
  1155.   End;
  1156.  
  1157.   {*Include File End CHGDIR.INC ***** END *****}
  1158.  
  1159.   {*Include File     MENUPROC.INC ***** START *****}
  1160.  Procedure Display(Var buffer);
  1161.   Type
  1162.    LineRec=Record
  1163.             y:Byte;
  1164.             x:Byte;
  1165.             txt:String[255];
  1166.            End;
  1167.  
  1168.   Var
  1169.    MenuLine:LineRec Absolute buffer;
  1170.    I:Integer;
  1171.    flag:Boolean;
  1172.   Begin
  1173.    With MenuLine Do
  1174.     Begin
  1175.      If x=$FF Then
  1176.       Begin
  1177.        I:=1;
  1178.        While txt[I]<>#03 Do
  1179.         I:=I+1;
  1180.        x:=40-((I) Shr 1);
  1181.       End;
  1182.      GoToXY(x,y+1);
  1183.      If txt[0]=Chr(2) Then
  1184.       Begin
  1185.        I:=1;
  1186.        flag:=True;
  1187.        While txt[I]<>#03 Do
  1188.         Begin
  1189.          If flag And (txt[I]>#$20) Then
  1190.           flag:=False;
  1191.          I:=I+1;
  1192.         End;
  1193.        If Not flag Then
  1194.         txt[0]:=Chr(I-1)
  1195.        Else
  1196.         txt[0]:=Chr(0);
  1197.       End;
  1198.      If Length(txt)>0 Then
  1199.       Write(txt);
  1200.     End;
  1201.   End;
  1202.  
  1203.  Procedure Entry(I:Integer;Var b,o:Byte;Var buffer);
  1204.   Type
  1205.    OffRec=Record
  1206.            offset:Byte;
  1207.            blk:Byte;
  1208.           End;
  1209.    OffTable=Array[0..52] Of OffRec;
  1210.   Var
  1211.    table:OffTable Absolute buffer;
  1212.   Begin
  1213.    With table[I] Do
  1214.     Begin
  1215.      b:=blk;
  1216.      o:=offset;
  1217.     End;
  1218.   End;
  1219.  
  1220.  Procedure RunInfo(Var buffer;
  1221.                    Var FName:Str80;
  1222.                    Var Path:Str80;
  1223.                    Var Drive:Str80;
  1224.                    Var ParmStr:Str80;
  1225.                    Var flag:Byte;
  1226.                    Var help:Byte);
  1227.   Type
  1228.    RunRec=Record
  1229.            pflag:Byte;
  1230.            phelp:Byte;
  1231.            junk:Byte;
  1232.            pdisk:Byte;
  1233.            ptxt:Array[1..255] Of Char;
  1234.           End;
  1235.   Var
  1236.    prec:RunRec Absolute buffer;
  1237.    F,T:Integer;
  1238.    k,P:Integer;
  1239.    I:Integer;
  1240.   Begin
  1241.    With prec Do
  1242.     Begin
  1243.      flag:=pflag;
  1244.      help:=phelp;
  1245.      If pdisk=0 Then
  1246.       FName:=''
  1247.      Else
  1248.       FName:=Chr($40+pdisk)+':';
  1249.      Drive:=FName;
  1250.      Path:='';
  1251.      F:=Length(Path);
  1252.      k:=1;
  1253.      If (ptxt[k]='/') Or (ptxt[k]='\') Then
  1254.       Begin
  1255.        Repeat
  1256.         F:=F+1;
  1257.         Path[F]:=ptxt[k];
  1258.         k:=k+1;
  1259.        Until ptxt[k]=#$20;
  1260.        k:=k+1;
  1261.        Path[0]:=Chr(F-1);
  1262.       End;
  1263.      F:=Length(FName);
  1264.      P:=k+8;
  1265.      T:=0;
  1266.      For I:=k To k+10 Do
  1267.       Begin
  1268.        If ptxt[I]<>#$20 Then
  1269.         Begin
  1270.          If (I>=P) And (T=0) Then
  1271.           Begin
  1272.            T:=1;
  1273.            F:=F+1;
  1274.            FName[F]:='.';
  1275.           End;
  1276.          F:=F+1;
  1277.          FName[F]:=ptxt[I];
  1278.         End;
  1279.       End;
  1280.      FName[0]:=Chr(F);
  1281.      ParmStr:='';
  1282.      k:=0;
  1283.      I:=I+1;
  1284.      While ptxt[I]<>#$03 Do
  1285.       Begin
  1286.        k:=k+1;
  1287.        ParmStr[k]:=ptxt[I];
  1288.        I:=I+1;
  1289.       End;
  1290.      ParmStr[0]:=Chr(k);
  1291.     End;
  1292.   End;
  1293.  
  1294.  
  1295.   {*Include File End MENUPROC.INC ***** END *****}
  1296.   {*Include File     DISPHELP.INC ***** START *****}
  1297.  Procedure DisplayHelp(I:Byte;Var HBuffer:HelpBuffer);
  1298.   Var
  1299.    k,L:Integer;
  1300.    b,o:Byte;
  1301.    T:Char;
  1302.   Begin
  1303.    ClrScr;
  1304.    LowVideo;
  1305.    L:=1+(I-1)*22;
  1306.    For k:=L To L+21 Do
  1307.     Begin
  1308.      Entry(k,b,o,HBuffer);
  1309.      Display(HBuffer.Buf[b,o]);
  1310.     End;
  1311.    NormVideo;
  1312.    GoToXY(1,24);Write('Press Any Key to Return');
  1313.    LowVideo;
  1314.    Read(Kbd,T);
  1315.    ClrScr;
  1316.   End;
  1317.  
  1318.   {*Include File End DISPHELP.INC ***** END *****}
  1319.   {*Include File     DISPMENU.INC ***** START *****}
  1320.  Procedure DisplayMenu(UserSel:Integer;Var MBuffer:MenuBuffer);
  1321.   Var
  1322.    k:Integer;
  1323.    L:Integer;
  1324.    b,o:Byte;
  1325.   Begin
  1326.    ClrScr;
  1327.    NormVideo;
  1328.    GoToXY(5,5);Write('Select and then Proceed:');
  1329.    LowVideo;
  1330.    For k:=1 To 3 Do
  1331.     Begin
  1332.      Entry(k,b,o,MBuffer);
  1333.      Display(MBuffer.Buf[b,o]);
  1334.     End;
  1335.    Entry(0,b,o,MBuffer);
  1336.    L:=MBuffer.Buf[b,o+1].b-1;
  1337.    For k:=0 To L Do
  1338.     Begin
  1339.      If k=UserSel Then
  1340.       NormVideo
  1341.      Else
  1342.       LowVideo;
  1343.      Entry(k+4,b,o,MBuffer);
  1344.      Display(MBuffer.Buf[b,o]);
  1345.      LowVideo;
  1346.     End;
  1347.    GoToXY(50,21);Write('RETURN   -   Proceed');
  1348.    GoToXY(50,22);Write('TAB      -   Help');
  1349.    GoToXY(50,23);Write('SPACE    -   Select');
  1350.    GoToXY(50,24);Write('ESCAPE   -   Previous Menu');
  1351.   End;
  1352.  
  1353.  Procedure HighLight(Var Old:Byte;New:Byte;MBuffer:MenuBuffer);
  1354.   Var
  1355.    b,o:Byte;
  1356.   Begin
  1357.    LowVideo;
  1358.    Entry(Old+4,b,o,MBuffer);
  1359.    Display(MBuffer.Buf[b,o]);
  1360.    NormVideo;
  1361.    Old:=New;
  1362.    Entry(Old+4,b,o,MBuffer);
  1363.    Display(MBuffer.Buf[b,o]);
  1364.    LowVideo;
  1365.   End;
  1366.  
  1367.  Procedure ReadMenu(Var FName:Str80;Var Good:Boolean);
  1368.   Var
  1369.    k:Integer;
  1370.    FilVar:ByteFile;
  1371.    Result:Integer;
  1372.    Path:Str255;
  1373.  
  1374.   Begin
  1375.    Path:=FindFile(FName);
  1376.    Assign(FilVar,Path+FName);
  1377.    {$I-}Reset(FilVar);                      {$I+}
  1378.    Good:=(IOResult=0);
  1379.    If Good Then
  1380.     Begin
  1381.      k:=1;
  1382.      Repeat
  1383.       With MBuffer Do
  1384.        DosBlockRead(FileHandle(FilVar),Buf[k],4096,Result);
  1385.       k:=k+16;
  1386.      Until Result=0;
  1387.      Close(FilVar);
  1388.     End;
  1389.   End;
  1390.  
  1391.  Procedure ReadHelp(Var FName:Str80;Var Good:Boolean);
  1392.   Var
  1393.    k:Integer;
  1394.    FilVar:ByteFile;
  1395.    Result:Integer;
  1396.    Path:Str255;
  1397.  
  1398.   Begin
  1399.    Path:=FindFile(FName);
  1400.    Assign(FilVar,Path+FName);
  1401.    {$I-}Reset(FilVar);                      {$I+}
  1402.    Good:=(IOResult=0);
  1403.    If Good Then
  1404.     Begin
  1405.      k:=1;
  1406.      Repeat
  1407.       With HBuffer Do
  1408.        DosBlockRead(FileHandle(FilVar),Buf[k],4096,Result);
  1409.       k:=k+16;
  1410.      Until Result=0;
  1411.      Close(FilVar);
  1412.     End;
  1413.   End;
  1414.  
  1415.  Procedure Menu(FName,Path,Drive:Str80;Var Ok:Boolean);
  1416.   Var
  1417.    OkDir,
  1418.    HelpCheck,
  1419.    MenuOk,
  1420.    HelpAvailable:Boolean;
  1421.    UserSel:Byte;
  1422.    T,TC:Char;
  1423.    CDrive:Str2;
  1424.    CurrentDir:String[80];
  1425.    L:Byte;
  1426.    FirstLetter:String[24];
  1427.    b,o:Byte;
  1428.    k:Byte;
  1429.    HFname,
  1430.    Rname,
  1431.    Rpath,
  1432.    Rdrive,
  1433.    Rparm:Str80;
  1434.    Rflag,
  1435.    Rhelp:Byte;
  1436.    R:Integer;
  1437.   Begin
  1438.    Ok:=True;
  1439.    CurrentDirectory(CurrentDir);
  1440.    CurrentDrive(CDrive);
  1441.    If Length(Drive)>0 Then
  1442.     ChangeDir(Drive,Ok)
  1443.    Else
  1444.     Drive:=CDrive;
  1445.    If (Length(Path)>0) And Ok Then
  1446.     ChangeDir(Path,Ok)
  1447.    Else
  1448.     Path:=CurrentDir;
  1449.    If Ok Then ReadMenu(FName,Ok);
  1450.    HFname:=Copy(FName,1,Pos('.',FName))+'hlp';
  1451.    HelpCheck:=False;
  1452.    If Ok Then
  1453.     Begin
  1454.      Entry(0,b,o,MBuffer);
  1455.      L:=MBuffer.Buf[b,o+1].b;
  1456.      For k:=4 To L+3 Do
  1457.       Begin
  1458.        Entry(k,b,o,MBuffer);
  1459.        FirstLetter[k-3]:=MBuffer.Buf[b,o+3].C;
  1460.       End;
  1461.      FirstLetter[0]:=Chr(L);
  1462.      UserSel:=0;
  1463.      DisplayMenu(UserSel,MBuffer);
  1464.      T:=#0;
  1465.      Repeat
  1466.       If KeyPressed Then
  1467.        Begin
  1468.         Read(Kbd,T);
  1469.         T:=UpCase(T);
  1470.         Message('');
  1471.         If (T In Special) Then
  1472.          Case T Of
  1473.           RETURN_Key:Begin
  1474.                       Entry(UserSel+4+L,b,o,MBuffer);
  1475.                       RunInfo(MBuffer.Buf[b,o],Rname,Rpath,Rdrive,Rparm,Rflag,Rhelp);
  1476.                       If Rflag=0 Then
  1477.                        Begin
  1478.                         Menu(Rname,Rpath,Rdrive,MenuOk);
  1479.                         If MenuOk Then
  1480.                          Begin
  1481.                           ReadHelp(HFname,HelpAvailable);
  1482.                           ReadMenu(FName,Ok);
  1483.                           DisplayMenu(UserSel,MBuffer);
  1484.                          End
  1485.                         Else
  1486.                          Message('Unable to access Menu '+Rname);
  1487.                        End
  1488.                       Else
  1489.                        If (Rflag=1) Or (Rflag=3) Then
  1490.                         Begin
  1491.                          OkDir:=True;
  1492.                          If Length(Rdrive)>0 Then
  1493.                           ChangeDir(Rdrive,OkDir);
  1494.                          If (Length(Rpath)>0) And OkDir Then
  1495.                           ChangeDir(Rpath,OkDir);
  1496.                          ClrScr;
  1497.                          CursorSize(NormalCursor);
  1498.                          If OkDir Then
  1499.                           R:=SubProcess(GetComSpec+' '+
  1500.                           SwitchChar+'C '+Rname+' '+
  1501.                           Rparm)
  1502.                          Else
  1503.                           R:=1;
  1504.                          CursorSize(NoCursor);
  1505.                          If (R=0) And (Rflag=3) Then
  1506.                           Begin
  1507.                            NormVideo;GoToXY(1,25);ClrEol;
  1508.                            Write('Press any Key to Return to Menu');
  1509.                            Read(Kbd,T);
  1510.                            LowVideo;
  1511.                           End;
  1512.                          ReturnToPath(Drive+Path);
  1513.                          DisplayMenu(UserSel,MBuffer);
  1514.                          If R<>0 Then
  1515.                           Begin
  1516.                            If OkDir Then
  1517.                             Message('Unable to run '+Rname)
  1518.                            Else
  1519.                             Message('Unable to find '+Rdrive+Rpath);
  1520.                           End;
  1521.                         End
  1522.                       Else
  1523.                        If Rflag=2 Then
  1524.                         Begin
  1525.                          GoToXY(5,5);ClrEol;LowVideo;
  1526.                          Write('File Spec: ');
  1527.                          NormVideo;
  1528.                          CursorSize(NormalCursor);
  1529.                          Rname:='';
  1530.                          InputStr(Rname,60,17,5,[RETURN_Key,ESCAPE_Key],TC);
  1531.                          LowVideo;
  1532.                          If (Length(Rname)>0) And (TC=RETURN_Key) Then
  1533.                           Begin
  1534.                            ClrScr;
  1535.                            R:=SubProcess(GetComSpec+' '+SwitchChar+'C '+Rname);
  1536.                            CursorSize(NoCursor);
  1537.                            If (R=0) Then
  1538.                             Begin
  1539.                              NormVideo;GoToXY(1,25);ClrEol;
  1540.                              Write('Press any Key to Return to Menu');
  1541.                              Read(Kbd,T);
  1542.                              LowVideo;
  1543.                             End;
  1544.                            ReturnToPath(Drive+Path);
  1545.                            DisplayMenu(UserSel,MBuffer);
  1546.                            If R<>0 Then
  1547.                             Message('Unable to run '+Rname);
  1548.                           End
  1549.                          Else
  1550.                           Begin
  1551.                            CursorSize(NoCursor);
  1552.                            DisplayMenu(UserSel,MBuffer)
  1553.                           End;
  1554.                         End
  1555.                       Else
  1556.                        If Rflag=4 Then
  1557.                         Begin
  1558.                          CursorSize(NormalCursor);
  1559.                          ClrScr;
  1560.                          NormVideo;
  1561.                          WriteLn('Type EXIT to return to the Menu');
  1562.                          LowVideo;
  1563.                          R:=SubProcess(GetComSpec);
  1564.                          ReturnToPath(Drive+Path);
  1565.                          CursorSize(NoCursor);
  1566.                          If R=0 Then
  1567.                           DisplayMenu(UserSel,MBuffer)
  1568.                          Else
  1569.                           Message('Unable to run '+Rname);
  1570.                         End
  1571.                       Else
  1572.                        If Rflag=5 Then
  1573.                         Begin
  1574.                          OkDir:=True;
  1575.                          If Length(Rdrive)>0 Then
  1576.                           ChangeDir(Rdrive,OkDir);
  1577.                          If (Length(Rpath)>0) And OkDir Then
  1578.                           ChangeDir(Rpath,OkDir);
  1579.                          CursorSize(NormalCursor);
  1580.                          LowVideo;
  1581.                          ClrScr;
  1582.                          If OkDir Then
  1583.                           R:=SubProcess(GetComSpec+' '+SwitchChar+'C '+Rname)
  1584.                          Else
  1585.                           R:=1;
  1586.                          CursorSize(NoCursor);
  1587.                          ReturnToPath(Drive+Path);
  1588.                          If (R=0) Then
  1589.                           Begin
  1590.                            NormVideo;GoToXY(1,25);ClrEol;
  1591.                            Write('Press any Key to Return to Menu');
  1592.                            Read(Kbd,T);
  1593.                            LowVideo;
  1594.                           End;
  1595.                          DisplayMenu(UserSel,MBuffer);
  1596.                          If R<>0 Then
  1597.                           Begin
  1598.                            If OkDir Then
  1599.                             Message('Unable to run '+Rname)
  1600.                            Else
  1601.                             Message('Unable to find '+Rdrive+Rpath);
  1602.                           End;
  1603.                         End
  1604.                       Else
  1605.                        Beep;
  1606.                      End;
  1607.  
  1608.           TAB_Key:Begin
  1609.                    Entry(UserSel+4+L,b,o,MBuffer);
  1610.                    RunInfo(MBuffer.Buf[b,o],Rname,Rpath,Rdrive,Rparm,Rflag,Rhelp);
  1611.                    If Rhelp=0 Then
  1612.                     Begin
  1613.                      Beep;
  1614.                      Message('Help not available');
  1615.                     End
  1616.                    Else
  1617.                     Begin
  1618.                      If Not HelpCheck Then
  1619.                       ReadHelp(HFname,HelpAvailable);
  1620.                      HelpCheck:=True;
  1621.                      If HelpAvailable Then
  1622.                       Begin
  1623.                        DisplayHelp(Rhelp,HBuffer);
  1624.                        DisplayMenu(UserSel,MBuffer);
  1625.                       End
  1626.                      Else
  1627.                       Begin
  1628.                        Beep;
  1629.                        Message('Help not available');
  1630.                       End;
  1631.                     End;
  1632.                   End;
  1633.  
  1634.           #$20:Begin
  1635.                 k:=(UserSel+1) Mod L;
  1636.                 HighLight(UserSel,k,MBuffer);
  1637.                End;
  1638.  
  1639.           BACKSPACE_Key:Begin
  1640.                          If k>0 Then
  1641.                           k:=UserSel-1
  1642.                          Else
  1643.                           k:=L-1;
  1644.                          HighLight(UserSel,k,MBuffer);
  1645.                         End;
  1646.          End
  1647.         Else
  1648.          If Pos(T,FirstLetter)<>0 Then
  1649.           Begin
  1650.            k:=Pos(T,Copy(FirstLetter,UserSel+2,L));
  1651.            If k=0 Then
  1652.             k:=Pos(T,Copy(FirstLetter,1,UserSel))
  1653.            Else
  1654.             k:=k+UserSel+1;
  1655.            If k=0 Then
  1656.             Beep
  1657.            Else
  1658.             HighLight(UserSel,k-1,MBuffer);
  1659.           End
  1660.         Else
  1661.          Beep;
  1662.        End;
  1663.       GoToXY(1,1);Write(Time);
  1664.       GoToXY(71,1);Write(CurrentDate);
  1665.      Until T=ESCAPE_Key;
  1666.     End;
  1667.    ReturnToPath(CDrive+CurrentDir);
  1668.   End;
  1669.  
  1670.  
  1671.  
  1672.   {*Include File End DISPMENU.INC ***** END *****}
  1673.  
  1674.  Begin
  1675.   NoCursor:=$1f1f;
  1676.   ReadCursor(NormalCursor);
  1677.   SwitchChar:=GetDOSswitch;
  1678.   CursorSize(NoCursor);
  1679.   (*  REPEAT         *)
  1680.   Menu('menu.dat','','',Ok);
  1681.   (*  UNTIL NOT Ok;  *)
  1682.   CursorSize(NormalCursor);
  1683.  End.
  1684.