Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB30.ZIP/TRBOEXT.PAS

Pascal/Delphi Source File | 1985-05-07 | 12.3 KB | 468 lines

{  Turbo Pascal procedure to retrieve command line parameters       }


type parmtype   = string[127];

     anystring  = string[132];

var
   tempstring:    anystring;

     {  Returns first available parameter from DOS command     }
     {  line and removes it so next parameter will be          }
     {  returned in next call.  If no more parameters are      }
     {  available, returns a null string.                      }

procedure getparm(var  s:parmtype);
var   parms:  parmtype absolute CSEG:$80;
begin
   s := '';        { parms[1] exists even when length is zero  }
   while (length(parms) > 0) and (parms[1] = ' ') do
      delete(parms,1,1);
   while (length(parms) > 0) and (parms[1] <> ' ') do
   begin
      s := s+parms[1];
      delete(parms,1,1)
   end;
end;
{
.pa  }

{***************************************************************************}
{*                                                                         *}
{*                   Date and Time Functions                               *}
{*                                                                         *}
{***************************************************************************}

type datetimetype    = string[8];
     regtype         = record
                       ax,bx,cx,dx,bp,si,di,ds,es,flags:  integer
                       end;

function date: datetimetype;    { Returns current date in form '02/08/85'. }
var   reg:   regtype;
      y,m,d,w:  datetimetype;
      i:        integer;

begin
   reg.ax := $2A00;
   intr($21,reg);
   str(reg.cx:4,y);
   delete(y,1,2);
   str(hi(reg.dx):2,m);
   str(lo(reg.dx):2,d);
   w := m + '/' + d + '/' + y;
   for i := 1 to length(w) do if w[i] = ' ' then w[i] := '0';
   date := w
end;

function time:  datetimetype;    { Returns current time in form '08:13:59'. }
var   reg:     regtype;
      h,m,s,w: datetimetype;
      i:       integer;

begin
   reg.ax := $2C00;
   intr($21,reg);
   str(hi(reg.cx):2,h);
   str(lo(reg.cx):2,m);
   str(hi(reg.dx):2,s);
   w := h + ':' + m + ':' + s;
   for i := 1 to length(w) do if w[i] = ' ' then w[i] := '0';
   time := w
end;

procedure SetDate(x:datetimetype);   { Sets date  Accepts string in format '02/08/85'.  }
var   reg:            regtype;
      rh,rl,c1,c2,c3: integer;

begin
   reg.ax := $2B00;
   val(x[1]+x[2],rh,c1);        { month goes in DH  }
   val(x[4]+x[5],rl,c2);        { day goes in DL    }
   reg.dx := rh*256 + rl;
   val(x[7]+x[8],rl,c3);        { year goes in CX   }
   reg.cx := rl + 1900;
   if rl < 80 then reg.cx := reg.cx + 100;    { 21st century  }
   c1 := c1+c2+c3;              { return codes from val }
   if c1 = 0 then intr($21,reg);
   if c1 + lo(reg.ax) <> 0 then
   begin
      writeln;
      writeln('Error---Invalid date, ''',x,'''');
      halt
   end
end;

procedure SetTime(x:datetimetype); { Sets time  Accepts string in format '08:13:59'. }
var   reg:            regtype;
      rh,rl,c1,c2,c3: integer;
begin
   reg.ax := $2D00;
   val(x[1]+x[2],rh,c1);        { Hours go in CH        }
   val(x[4]+x[5],rl,c2);        { Minutes go in CL      }
   reg.cx := rh*256 + rl;
   val(x[7]+x[8],rh,c3);        { Seconds go in DH      }
   reg.dx := rh*256;
   c1 := c1+c2+c3;              { return codes from VAL }
   if c1 = 0 then intr($21,reg);
   if c1+lo(reg.ax) <> 0 then
   begin
      writeln;
      writeln('Error -- Invalid time, ''',x,'''');
      halt
   end
end;
{
.pa  }

{***************************************************************************}
{*                                                                         *}
{*                   Directory Tree Functions                              *}
{*                                                                         *}
{***************************************************************************}

type    pathtype    = string[63];
        drivetype   = string[2];
        rtype       = record
                        ax,bx,cx,dx,bp,si,di,ds,es,flags:  integer
                      end;

procedure XxDiskErr(x:drivetype);
begin
   writeln('Error -- Invalid disk drive, ''',x,'''');
   halt
end;

procedure xxpatherr(x:pathtype);
begin
   writeln('Error -- Invalid path, ''',x,'''');
   halt
end;

{ Returns designator for current default drive, e.g., 'A:'.  }

function CurrentDrive:  drivetype;
var   w:   drivetype;
      reg: rtype;
begin
   reg.ax := $1900;
   intr($21,reg);
   w := 'A:';
   w[1] := chr(ord(w[1]) + lo(reg.ax));
   CurrentDrive := w
end;

{ Chooses a new default drive.      }
{ Parameter can have the form 'A:', 'A', 'a:', or 'a'.     }

procedure ChDrive(x: drivetype);
var  reg:  rtype;
begin
   reg.ax := $0E00;
   reg.dx := ord(upcase(x[1])) - ord('A');
   intr($21,reg);
   if (reg.dx < 0) or (lo(reg.ax) < lo(reg.dx)) then xxdiskerr(x);
end;

{ Returns number of bytes available on specified disk.      }
{ Parameter as for CHDRIVE.                                 }

function DiskSpace(x: drivetype): real;
var  reg: rtype;
begin
   reg.ax := $3600;
   reg.dx := 1 + ord(upcase(x[1])) - ord('A');
   intr($21,reg);
   if reg.ax = $FFFF then
      xxdiskerr(x)
   else
      diskspace := (256.0*hi(reg.dx)+lo(reg.dx)) * reg.ax * reg.cx
end;

{  Returns full path to active directory on specified drive,  }
{  including backslash at beginning, not including drive      }
{  designator.  Parameter as for CHDRIVE.                     }

function CurrentDir(x: drivetype): pathtype;
var   w:     pathtype;
      reg:   rtype;
      i:     integer;
begin
   reg.ax := $4700;                 { get current path  }
   reg.dx := 1 + ord(upcase(x[1])) - ord('A');
   reg.ds := seg(w[1]);
   reg.si := ofs(w[1]);
   intr($21,reg);
   if (reg.flags and 1) > 0 then xxdiskerr(x);

{  Convert to Turbo string  }
   i := 1;
   while w[i] <> chr(0) do i := i+1;
   w[0] := chr(i-1);
   for i := 1 to length(w) do w[i] := upcase(w[i]);

   CurrentDir := '\' + w
end;

{  Executed CHDIR, MKDIR, and RMDIR requests.     }
procedure xxdir(x: pathtype;  k: integer);
var    w:    pathtype;
       reg:  rtype;
begin
   w := x + chr(0);
   if w[2] <> ':' then    { add drive designator    }
       w := CurrentDrive + w;
    reg.ax := k;
    reg.ds := seg(w[1]);
    reg.dx := ofs(w[1]);
    intr($21,reg);
    if (reg.flags and 1) > 0 then xxpatherr(x)
 end;


{  Equivalent to CHDIR command in DOS.       }
{  CAUTION!!!!  Do not leave a directory     }
{     if you have files in it open!          }
procedure Chdir(x: pathtype);
begin
   xxdir(x,$3B00)
end;


{  Equivalent to RMDIR command in DOS.       }

procedure Rmdir(x: pathtype);
begin
   xxdir(x,$3A00)
end;

{  Equivalent to MKDIR command in DOS.      }
procedure mkdir(x:pathtype);
begin
   xxdir(x,$3900);
end;

{  Renames a file; unlike the DOS RENAME command,   }
{  both parameters of this command are full paths.  }
{  The paths need not be the same, allowing a file  }
{  to be moved from one directory to another.       }
{  First parameter can specify a drive; any drive   }
{  letter on the second parameter is ignored.       }

procedure rename(x,y: pathtype);
var   wx,wy:   pathtype;
      reg:     rtype;
begin
   wx := x + chr(0);
   wy := y + chr(0);
   if wx[2] <> ':' then wx := currentdrive + wx;
   reg.ax := $5600;
   reg.ds := seg(wx[2]);
   reg.dx := ofs(wx[1]);
   reg.es := seg(wy[1]);
   reg.di := ofs(wy[1]);
   intr($21,reg);
   if (reg.flags and 1) <> 0 then
   begin
      writeln('Error -- Invalid rename request');
      writeln('      -- From: ''',x,'''');
      writeln('      -- To:   ''',y,'''');
      halt
   end
end;
{
.pa  }


{  Turbo Pascal  removable window system       }

{  Requirements:   IBM PC or close compatible. }
{  Screen must be in text mode, on page 1,     }
{  either mono or color card.                  }

{  Call INITWIN before calling MKWIN or RMWIN. }

const maxwin = 5;              { maximum number of windows open at once   }

type  imagetype    = array [1..4096] of char;
      windimtype   = record
                        x1,y1,x2,y2:  integer
                     end;

var
   win:                        { Global variable package                 }
      record
         dim:     windimtype;  { Current window dimensions               }
         depth:   integer;
         stack:   array[1..maxwin] of
                     record
                        image:  imagetype;   { saved screen image        }
                        dim:    windimtype;  { saved window dimensions   }
                        x,y:    integer      { saved cursor position     }
                     end
      end;

   crtmode:       byte        absolute $0040:$0049;
   crtwidth:      byte        absolute $0040:$004A;
   monobuffer:    imagetype   absolute $B000:$0000;
   colorbuffer:   imagetype   absolute $B800:$0000;

procedure InitWin;       {   Records initial window dimensions    }
begin
   with win.dim do
   begin
      x1 := 1;
      y1 := 1;
      x2 := crtwidth;
      y2 := 25
   end;
   win.depth := 0
end;
{
.pa }

{ Draw a box, fill it with blanks, and make it the current     }
{ window.  Dimensions given are for the box; actual window is  }
{ one unit smaller in each direction.                          }
{ This routine can be used separately from the rest of the     }
{ removable window package.                                    }

procedure BoxWin(x1,y1,x2,y2:  integer);
var  x,y:  integer;
begin
   window(1,1,80,25);     {Top}
   GotoXY(x1,y1);
   write(chr(213));
   for x := x1+1 to x2-1 do write(chr(205));
   write(chr(184));

   for y := y1+1 to y2-1 do  {Sides}
   begin
      GotoXY(x1,y);
      write(chr(179),' ':x2-x1-1,chr(179))
   end;

   GotoXY(x1,y2);          {Bottom}
   write(chr(212));
   for x := x1+1 to x2-1 do write(chr(205));
   write(chr(190));

   window(x1+1,y1+1,x2-1,y2-1);     { Make it the current window  }
   GotoXY(1,1)
end;


{  Create a movable window   }

procedure MkWin(x1,y1,x2,y2:  integer);
begin
   with win do depth := depth+1;       { increment stack pointer  }
   if win.depth > maxwin then
   begin
      writeln(^G,' Windows nested too deep ');
      halt
   end;

                     {  Save contents of screen     }
   if crtmode = 7 then
      win.stack[win.depth].image := monobuffer
   else
      win.stack[win.depth].image := colorbuffer;

   win.stack[win.depth].dim := win.dim;
   win.stack[win.depth].x   := wherex;
   win.stack[win.depth].y   := wherey;

   { Create the window  }

   boxwin(x1,y1,x2,y2);
   win.dim.x1 := x1+1;
   win.dim.y1 := y1+1;    { Allow for margins   }
   win.dim.x2 := x2-1;
   win.dim.y2 := y2-1;
end;

  {  Remove the most recently created removable window    }
  {  Restore screen contents, window dimensions, and      }
  {  position of cursor.                                  }

procedure rmwin;
begin
   if crtmode = 7 then
      monobuffer := win.stack[win.depth].image
   else
      colorbuffer := win.stack[win.depth].image;
   with win do
   begin
      dim := stack[depth].dim;
      window(dim.x1,dim.y1,dim.x2,dim.y2);
      GotoXY(stack[depth].x,stack[depth].y);
      depth := depth -1
   end
end;






{
.pa  }

{  Test program for removable window package    }


var  i:  integer;
begin
   initwin;
   writeln('Now and every time the action stops,');
   writeln('press ENTER to continue');
   readln;
   clrscr;
   for i := 1 to 25 do writeln('    This is the original screen.');

   mkwin(3,3,50,18);
   for i := 1 to 15 do writeln('This is the first window....');
   readln;

   mkwin(10,5,70,20);
   for i := 1 to 15 do writeln('Second window....');
   readln;

   mkwin(15,15,45,23);
   writeln('Third window...');
   readln;

   mkwin(55,10,79,25);
   writeln('Fourth window....');
   readln;

   rmwin;    { remove fourth window  }
   readln;

   rmwin;    { remove third window   }
   writeln;
   writeln('We are back in the second window...');
   readln;

   rmwin;    { remove second window  }
   writeln;
   writeln('This is the first window again!');
   readln;

   rmwin;    { remove first window   }
   readln;

end.

;
   writeln('This is the first window again!');
   readln;

   rmwi