procedure wait_for_key;
var  anykey : char;
begin
  anykey := readkey;
  if (anykey = #0) then anykey := readkey;
end;

function Date: DateStr;
var
  gm,gd,gy,gdow : word;
  month,day:     string[2];
  year:          string[2];
  yr:            string[4];
begin
  GetDate(gy,gm,gd,gdow);
  str(gy,yr);                  {convert to string}
  str(gd,day);               { " }
  str(gm,month);               { " }
  year := '  ';
  year[1] := yr[3];
  year[2] := yr[4];
  if (month[0] = ^A) then month := '0' + month;
  if (day[0] = ^A) then day := '0' + day;
  date := month+'/'+day+'/'+year;
end;

function time: TimeString;
var
  gh,gm,gs,gs100 : word;
  hour,min,sec:     string[2];

begin
  GetTime(gh,gm,gs,gs100);
  str(gh, hour);                 {convert to string}
  str(gm, min);                       { " }
  if (hour[0] = ^A) then hour := '0' + hour;
  if (min[0] = ^A) then min := '0' + min;
  time := hour+':'+min;
end;

procedure get_time;
var gh,gm,gs,gs100 : word;
begin
  GetTime(gh,gm,gs,gs100);
  hour := gh;
  min  := gm;
end;

procedure get_date;
var gy,gm,gd,gdow : word;
begin
  GetDate(gy,gm,gd,gdow);
  year := gy;
  month := gm;
  day := gd;
end;

procedure set_time;
begin
  SetTime(hour,min,0,0);
end;

procedure set_date;
begin
  SetDate(year,month,day);
end;

procedure set_date_time;
begin
  if (time_zone <> 0) then
  begin
    get_date;
    get_time;
    hour := hour + time_zone;
    if (hour > 23) then
    begin
      hour := hour - 24;
      day := day + 1;
      if (day > nbr_days[month]) then
      begin
        day := 1;
        month := month + 1;
        if (month > 12) then
        begin
          month := 1;
          year := year + 1;
        end;
      end;
    end;
  set_date;
  set_time;
  end;
end;

procedure reset_date_time;
begin
  if (time_zone <> 0) then
  begin
    get_date;
    get_time;
    hour := hour - time_zone;
    if (hour < 0) then
    begin
      hour := hour + 24;
      day := day - 1;
      if (day = 0) then
      begin
        month := month - 1;
        if (month = 0) then
        begin
          month := 12;
          year := year - 1;
        end;
        day := nbr_days[month];
      end;
    end;
  set_date;
  set_time;
  end;
end;

procedure directory;

type
  filename = string[13];
  dtapointer = ^dtarecord;
  dtarecord = record
                dosreserved : array[1..21] of byte;
                attribute   : byte;
                filetime,
                filedate,
                sizelow,
                sizehigh    : integer;
                foundname   : array[1..13] of char;
              end;

const
  seekattrib = $10;

var
  transferrec : dtapointer;
  matchptrn   : file_type;
  retname     : filename;
  filsize     : real;
  count       : integer;
  nofind, lastfile, subdirec  : boolean;
  local_image : screen;

  procedure pointdta(var dtarec : dtapointer);
  const  getdta = $2F00;
  var    regs : Registers;
  begin
    regs.ax := getdta;
    MsDos(regs);
    dtarec := ptr(regs.es,regs.bx);
  end;

  function sizeoffile(hiword, loword : integer) : real;
  var  bigno, size : real;
  begin
    bigno := (MaxInt *2.0) + 2;
    if (hiword < 0) then size := (bigno + hiword) * bigno
       else size := hiword * bigno;
    if (loword >= 0) then size := size + loword
       else size := size + (bigno + loword);
    sizeoffile := size;
  end;

  procedure findfirst(pattern : file_type;
                      var found : filename;
                      var size  : real;
                      var nomatch : boolean;
                      var lastone : boolean;
                      var subdir : boolean);
  const  findfirst = $4E00;
  type   asciiz = array[1..64] of char;
  var    filespec : asciiz;
         regs     : Registers;
         posinstr,
         count    : integer;
         foundlen : byte absolute found;
  begin
    for posinstr := 1 to length(pattern) do
      filespec[posinstr] := pattern[posinstr];
    filespec[length(pattern)+1] := null;
    with regs do
    begin
      ds := seg(filespec);
      dx := ofs(filespec);
      cx := seekattrib;
      ax := findfirst;
      MsDos(regs);
      if (flags AND 1) > 0 then
        begin
          case ax of
            2  :  begin
                    nomatch := TRUE;
                    lastone := TRUE;
                  end;
           18  :  begin
                    nomatch := FALSE;
                    lastone := TRUE;
                  end;
          end;
        end
      else
        begin
          nomatch := FALSE;
          lastone := FALSE;
        end;
      end;
    if (NOT nomatch) then
  with transferrec^ do
    begin
      found := foundname;
      count := 0;
      while found[count] <> null do count := count + 1;
      foundlen := count;
      for count := length(found) + 1 to 15 { 13 } do
        found := found + ' ';
      if (attribute AND seekattrib) > 0
        then subdir := TRUE
        else subdir := FALSE;
      if NOT subdir
        then size := sizeoffile(sizehigh,sizelow)
        else size := 0.0;
    end;
  end;

  procedure findnext(var found : filename;
                     var size  : real;
                     var lastone : boolean;
                     var subdir : boolean);
  const   findnext = $4F00;
  var     regs : Registers;
          count : integer;
          foundlen : byte absolute found;
  begin
    with regs do
    begin
      ax := findnext;
      MsDos(regs);
      if ((flags AND 1) > 0) AND (ax = 18)
          then lastone := TRUE
          else lastone := FALSE;
    end;
    with transferrec^ do
    begin
      found := foundname;
      count := 0;
      while found[count] <> null do count := count + 1;
      foundlen := count;
      for count := length(found) + 1 to 15 { 13 } do
        found := found + ' ';
      if (attribute AND seekattrib) > 0
        then subdir := TRUE
        else subdir := FALSE;
      if NOT subdir
        then size := sizeoffile(sizehigh,sizelow)
        else size := 0.0;
    end;
  end;

begin
  case vid_type of
    0 : local_image := mono_screen;
    1 : local_image := color_screen;
  end;
  window(1,1,80,25);
  frame(4,3,77,10);
  window(5,4,76,9);
  aux_color;
  clrscr;
  write('File Name Pattern: ');
  readln(matchptrn);
  if matchptrn = '' then matchptrn := '*.*';
  count := 0;
  pointdta(transferrec);
  findfirst(matchptrn,retname,filsize,nofind,lastfile,subdirec);
  if nofind OR lastfile
    then writeln('File not found.')
    else
      begin
      clrscr;
        while (NOT lastfile) do
          begin
            if subdirec then status_color;
            write(retname ,':',filsize:8:0,'  ')  ;
            aux_color;
            count := count + 1;
            findnext(retname,filsize,lastfile,subdirec);
          end;
        end;
  writeln;
  write('                      Press any key to continue');
  wait_for_key;
  case vid_type of
    0 : mono_screen := local_image;
    1 : color_screen := local_image;
  end;
end;

procedure get_file_name(var name : file_type;
                        xp,yp : integer;
                        prompt : msg_type;
                        x1,y1,x2,y2 : integer;
                        color_spec : integer);
var i,x,y : integer;
    key : char;
begin
  name := '';
  gotoxy(xp,yp);
  write(prompt,' file ^F = dir, <ESC> ...');
  repeat
    repeat until keypressed;
    key := readkey;
    if (key = #0) then
      begin
        key := readkey;
        key := null;
      end;
    if (key = ^F) then
      begin
        x := WhereX;  y := WhereY;
        directory;
        window(x1,y1,x2,y2);
        gotoxy(x,y);
        case color_spec of
          0 : transmit_color;
          1 : receive_color;
          2 : status_color;
          3 : prompt_color;
          4 : aux_color;
          5 : help_color;
        end;
      end;
  until (key in [^M,#0,chr(32)..chr(127)]);
  if (key >= ' ') then
    begin
      write(key);
      name := key;
      repeat
        key := readkey;
        if (key = ^H) and (ord(name[0]) > 0)
        then
          begin
            name[0] := chr(ord(name[0]) - 1);
            write(^H,' ',^H);
          end
        else
          if (key > ' ') then
            begin
              write(key);
              name := name + key;
            end;
        if (key = #0) then
          qkey := readkey;
      until (key = #13);
    end;
end;

procedure UpperCase(VAR str : msg_type);
var i : integer;
begin
  if length(str) > 0 then
    for i := 1 to length(str) do
      if str[i] in ['a'..'z'] then str[i] := chr(ord(str[i]) AND $DF);
end;