home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1 / HamRadio.cdr / packet / kam300 / kam-dos.pas < prev    next >
Pascal/Delphi Source File  |  1988-03-31  |  9KB  |  369 lines
  1. procedure wait_for_key;
  2. var  anykey : char;
  3. begin
  4.   anykey := readkey;
  5.   if (anykey = #0) then anykey := readkey;
  6. end;
  7.  
  8. function Date: DateStr;
  9. var
  10.   gm,gd,gy,gdow : word;
  11.   month,day:     string[2];
  12.   year:          string[2];
  13.   yr:            string[4];
  14. begin
  15.   GetDate(gy,gm,gd,gdow);
  16.   str(gy,yr);                  {convert to string}
  17.   str(gd,day);               { " }
  18.   str(gm,month);               { " }
  19.   year := '  ';
  20.   year[1] := yr[3];
  21.   year[2] := yr[4];
  22.   if (month[0] = ^A) then month := '0' + month;
  23.   if (day[0] = ^A) then day := '0' + day;
  24.   date := month+'/'+day+'/'+year;
  25. end;
  26.  
  27. function time: TimeString;
  28. var
  29.   gh,gm,gs,gs100 : word;
  30.   hour,min,sec:     string[2];
  31.  
  32. begin
  33.   GetTime(gh,gm,gs,gs100);
  34.   str(gh, hour);                 {convert to string}
  35.   str(gm, min);                       { " }
  36.   if (hour[0] = ^A) then hour := '0' + hour;
  37.   if (min[0] = ^A) then min := '0' + min;
  38.   time := hour+':'+min;
  39. end;
  40.  
  41. procedure get_time;
  42. var gh,gm,gs,gs100 : word;
  43. begin
  44.   GetTime(gh,gm,gs,gs100);
  45.   hour := gh;
  46.   min  := gm;
  47. end;
  48.  
  49. procedure get_date;
  50. var gy,gm,gd,gdow : word;
  51. begin
  52.   GetDate(gy,gm,gd,gdow);
  53.   year := gy;
  54.   month := gm;
  55.   day := gd;
  56. end;
  57.  
  58. procedure set_time;
  59. begin
  60.   SetTime(hour,min,0,0);
  61. end;
  62.  
  63. procedure set_date;
  64. begin
  65.   SetDate(year,month,day);
  66. end;
  67.  
  68. procedure set_date_time;
  69. begin
  70.   if (time_zone <> 0) then
  71.   begin
  72.     get_date;
  73.     get_time;
  74.     hour := hour + time_zone;
  75.     if (hour > 23) then
  76.     begin
  77.       hour := hour - 24;
  78.       day := day + 1;
  79.       if (day > nbr_days[month]) then
  80.       begin
  81.         day := 1;
  82.         month := month + 1;
  83.         if (month > 12) then
  84.         begin
  85.           month := 1;
  86.           year := year + 1;
  87.         end;
  88.       end;
  89.     end;
  90.   set_date;
  91.   set_time;
  92.   end;
  93. end;
  94.  
  95. procedure reset_date_time;
  96. begin
  97.   if (time_zone <> 0) then
  98.   begin
  99.     get_date;
  100.     get_time;
  101.     hour := hour - time_zone;
  102.     if (hour < 0) then
  103.     begin
  104.       hour := hour + 24;
  105.       day := day - 1;
  106.       if (day = 0) then
  107.       begin
  108.         month := month - 1;
  109.         if (month = 0) then
  110.         begin
  111.           month := 12;
  112.           year := year - 1;
  113.         end;
  114.         day := nbr_days[month];
  115.       end;
  116.     end;
  117.   set_date;
  118.   set_time;
  119.   end;
  120. end;
  121.  
  122. procedure directory;
  123.  
  124. type
  125.   filename = string[13];
  126.   dtapointer = ^dtarecord;
  127.   dtarecord = record
  128.                 dosreserved : array[1..21] of byte;
  129.                 attribute   : byte;
  130.                 filetime,
  131.                 filedate,
  132.                 sizelow,
  133.                 sizehigh    : integer;
  134.                 foundname   : array[1..13] of char;
  135.               end;
  136.  
  137. const
  138.   seekattrib = $10;
  139.  
  140. var
  141.   transferrec : dtapointer;
  142.   matchptrn   : file_type;
  143.   retname     : filename;
  144.   filsize     : real;
  145.   count       : integer;
  146.   nofind, lastfile, subdirec  : boolean;
  147.   local_image : screen;
  148.  
  149.   procedure pointdta(var dtarec : dtapointer);
  150.   const  getdta = $2F00;
  151.   var    regs : Registers;
  152.   begin
  153.     regs.ax := getdta;
  154.     MsDos(regs);
  155.     dtarec := ptr(regs.es,regs.bx);
  156.   end;
  157.  
  158.   function sizeoffile(hiword, loword : integer) : real;
  159.   var  bigno, size : real;
  160.   begin
  161.     bigno := (MaxInt *2.0) + 2;
  162.     if (hiword < 0) then size := (bigno + hiword) * bigno
  163.        else size := hiword * bigno;
  164.     if (loword >= 0) then size := size + loword
  165.        else size := size + (bigno + loword);
  166.     sizeoffile := size;
  167.   end;
  168.  
  169.   procedure findfirst(pattern : file_type;
  170.                       var found : filename;
  171.                       var size  : real;
  172.                       var nomatch : boolean;
  173.                       var lastone : boolean;
  174.                       var subdir : boolean);
  175.   const  findfirst = $4E00;
  176.   type   asciiz = array[1..64] of char;
  177.   var    filespec : asciiz;
  178.          regs     : Registers;
  179.          posinstr,
  180.          count    : integer;
  181.          foundlen : byte absolute found;
  182.   begin
  183.     for posinstr := 1 to length(pattern) do
  184.       filespec[posinstr] := pattern[posinstr];
  185.     filespec[length(pattern)+1] := null;
  186.     with regs do
  187.     begin
  188.       ds := seg(filespec);
  189.       dx := ofs(filespec);
  190.       cx := seekattrib;
  191.       ax := findfirst;
  192.       MsDos(regs);
  193.       if (flags AND 1) > 0 then
  194.         begin
  195.           case ax of
  196.             2  :  begin
  197.                     nomatch := TRUE;
  198.                     lastone := TRUE;
  199.                   end;
  200.            18  :  begin
  201.                     nomatch := FALSE;
  202.                     lastone := TRUE;
  203.                   end;
  204.           end;
  205.         end
  206.       else
  207.         begin
  208.           nomatch := FALSE;
  209.           lastone := FALSE;
  210.         end;
  211.       end;
  212.     if (NOT nomatch) then
  213.   with transferrec^ do
  214.     begin
  215.       found := foundname;
  216.       count := 0;
  217.       while found[count] <> null do count := count + 1;
  218.       foundlen := count;
  219.       for count := length(found) + 1 to 15 { 13 } do
  220.         found := found + ' ';
  221.       if (attribute AND seekattrib) > 0
  222.         then subdir := TRUE
  223.         else subdir := FALSE;
  224.       if NOT subdir
  225.         then size := sizeoffile(sizehigh,sizelow)
  226.         else size := 0.0;
  227.     end;
  228.   end;
  229.  
  230.   procedure findnext(var found : filename;
  231.                      var size  : real;
  232.                      var lastone : boolean;
  233.                      var subdir : boolean);
  234.   const   findnext = $4F00;
  235.   var     regs : Registers;
  236.           count : integer;
  237.           foundlen : byte absolute found;
  238.   begin
  239.     with regs do
  240.     begin
  241.       ax := findnext;
  242.       MsDos(regs);
  243.       if ((flags AND 1) > 0) AND (ax = 18)
  244.           then lastone := TRUE
  245.           else lastone := FALSE;
  246.     end;
  247.     with transferrec^ do
  248.     begin
  249.       found := foundname;
  250.       count := 0;
  251.       while found[count] <> null do count := count + 1;
  252.       foundlen := count;
  253.       for count := length(found) + 1 to 15 { 13 } do
  254.         found := found + ' ';
  255.       if (attribute AND seekattrib) > 0
  256.         then subdir := TRUE
  257.         else subdir := FALSE;
  258.       if NOT subdir
  259.         then size := sizeoffile(sizehigh,sizelow)
  260.         else size := 0.0;
  261.     end;
  262.   end;
  263.  
  264. begin
  265.   case vid_type of
  266.     0 : local_image := mono_screen;
  267.     1 : local_image := color_screen;
  268.   end;
  269.   window(1,1,80,25);
  270.   frame(4,3,77,10);
  271.   window(5,4,76,9);
  272.   aux_color;
  273.   clrscr;
  274.   write('File Name Pattern: ');
  275.   readln(matchptrn);
  276.   if matchptrn = '' then matchptrn := '*.*';
  277.   count := 0;
  278.   pointdta(transferrec);
  279.   findfirst(matchptrn,retname,filsize,nofind,lastfile,subdirec);
  280.   if nofind OR lastfile
  281.     then writeln('File not found.')
  282.     else
  283.       begin
  284.       clrscr;
  285.         while (NOT lastfile) do
  286.           begin
  287.             if subdirec then status_color;
  288.             write(retname ,':',filsize:8:0,'  ')  ;
  289.             aux_color;
  290.             count := count + 1;
  291.             findnext(retname,filsize,lastfile,subdirec);
  292.           end;
  293.         end;
  294.   writeln;
  295.   write('                      Press any key to continue');
  296.   wait_for_key;
  297.   case vid_type of
  298.     0 : mono_screen := local_image;
  299.     1 : color_screen := local_image;
  300.   end;
  301. end;
  302.  
  303. procedure get_file_name(var name : file_type;
  304.                         xp,yp : integer;
  305.                         prompt : msg_type;
  306.                         x1,y1,x2,y2 : integer;
  307.                         color_spec : integer);
  308. var i,x,y : integer;
  309.     key : char;
  310. begin
  311.   name := '';
  312.   gotoxy(xp,yp);
  313.   write(prompt,' file ^F = dir, <ESC> ...');
  314.   repeat
  315.     repeat until keypressed;
  316.     key := readkey;
  317.     if (key = #0) then
  318.       begin
  319.         key := readkey;
  320.         key := null;
  321.       end;
  322.     if (key = ^F) then
  323.       begin
  324.         x := WhereX;  y := WhereY;
  325.         directory;
  326.         window(x1,y1,x2,y2);
  327.         gotoxy(x,y);
  328.         case color_spec of
  329.           0 : transmit_color;
  330.           1 : receive_color;
  331.           2 : status_color;
  332.           3 : prompt_color;
  333.           4 : aux_color;
  334.           5 : help_color;
  335.         end;
  336.       end;
  337.   until (key in [^M,#0,chr(32)..chr(127)]);
  338.   if (key >= ' ') then
  339.     begin
  340.       write(key);
  341.       name := key;
  342.       repeat
  343.         key := readkey;
  344.         if (key = ^H) and (ord(name[0]) > 0)
  345.         then
  346.           begin
  347.             name[0] := chr(ord(name[0]) - 1);
  348.             write(^H,' ',^H);
  349.           end
  350.         else
  351.           if (key > ' ') then
  352.             begin
  353.               write(key);
  354.               name := name + key;
  355.             end;
  356.         if (key = #0) then
  357.           qkey := readkey;
  358.       until (key = #13);
  359.     end;
  360. end;
  361.  
  362. procedure UpperCase(VAR str : msg_type);
  363. var i : integer;
  364. begin
  365.   if length(str) > 0 then
  366.     for i := 1 to length(str) do
  367.       if str[i] in ['a'..'z'] then str[i] := chr(ord(str[i]) AND $DF);
  368. end;
  369.