home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TDOSBIOS.ZIP / DOSBIOS.PAS next >
Encoding:
Pascal/Delphi Source File  |  1988-05-04  |  14.2 KB  |  627 lines
  1. Unit DosBios;
  2.  
  3. (* DosBios.Inc *)
  4.  
  5. (*    05/02/1988     J Tal
  6.                      Rollins Medical/Dental Systems
  7.         
  8.                      Public Domain
  9. *)
  10.  
  11. {$V-}
  12.  
  13. Interface
  14.  
  15.    Uses Dos,Funcs;
  16.  
  17.  
  18.  
  19.    TYPE
  20.       regpack = Dos.Registers;
  21.  
  22.       dta_date_type = record
  23.                       year,month,day: INTEGER;
  24.                     END;
  25.  
  26.       dta_time_type = record
  27.                       hour,min,sec: INTEGER;
  28.                    END;
  29.  
  30.      st255 = string[255];
  31.      scr_buffer_ptr = ^scr_buffer_type;
  32.      scr_buffer_type = ARRAY[1..4004] OF BYTE;
  33.  
  34.  
  35.    procedure wget(x,y,w,h: byte; buff_ptr : scr_buffer_ptr);
  36.  
  37.    procedure wput(x,y,w,h: byte; buff_ptr : scr_buffer_ptr);
  38.  
  39.    Procedure Scroll_Page_Up(x,y,w,h,lines,attrib: BYTE);
  40.  
  41.    Procedure Scroll_Page_Dn(x,y,w,h,lines,attrib: BYTE);
  42.  
  43.    Procedure Put_Cursor(x,y: BYTE);
  44.  
  45.    Procedure Get_Cursor(VAR x,y: BYTE);
  46.  
  47.    Procedure Get_Vattrib(VAR vchar,vattrib: byte);
  48.  
  49.    Procedure Put_Vattrib(vchar,vattrib: byte);
  50.  
  51.    Function get_Vmode: INTEGER;
  52.  
  53.    Function get_dos_ver_number : st255;
  54.  
  55.    Function get_date : st255;
  56.  
  57.    Function get_time : st255;
  58.  
  59.    Procedure Get_DTA(VAR DTA_SEG,DTA_OFS: WORD);
  60.  
  61.    Function Current_Drive : INTEGER;
  62.  
  63.    Function Get_Cur_Dir(cur_drive: INTEGER) : st255;
  64.  
  65.    Procedure DirFile(first: INTEGER; search_str: st255; DTA_SEG,DTA_OFS: WORD;
  66.                      VAR found_str: st255; VAR attrib: INTEGER);
  67.  
  68.    Procedure DelFile(fn: st255);
  69.  
  70.    Function ShiftState(ss: INTEGER): BOOLEAN;
  71.  
  72.    Procedure Disk_Free(Drive: WORD; VAR Disk_bytes, avail_bytes: LongInt);
  73.  
  74.    Function DayOfWeek(dstr: st255) : INTEGER;
  75.  
  76.    Procedure ReadDTA(VAR disk_time,disk_date: INTEGER; DTA_SEG,DTA_OFS: WORD;
  77.                      VAR DTA_attrib: WORD; VAR dsize: LongInt);
  78.  
  79.    Procedure Do_DTA_Date(disk_date,disk_time: INTEGER; DTA_SEG,DTA_OFS: WORD;
  80.                       VAR DTA_Date: dta_date_type; VAR dta_time: dta_time_type);
  81.  
  82.    Procedure Open_File(f:st255; omode: INTEGER; VAR fhandle: INTEGER);
  83.  
  84.    Procedure Close_File(fhandle: INTEGER);
  85.  
  86.    Procedure LSeek(fhandle,smode: INTEGER; flen: LongInt);
  87.  
  88.    Procedure Write_File(fhandle,buf_seg,buf_adr,bytes: INTEGER);
  89.  
  90.    Procedure SetFileTime(fhandle,time_word,date_word: INTEGER);
  91.  
  92.    Procedure GetFileTime(fhandle,time_word,date_word: INTEGER);
  93.  
  94.    Procedure F_Copy(source,dest: st255; disk_time,disk_date: INTEGER; flen: LongInt);
  95.  
  96.    Function Mem_Free : LongInt;
  97.  
  98.    Function Mem_Installed : LongInt;
  99.  
  100.  
  101.  
  102. Implementation
  103. {$L Pwindow}
  104.  
  105. VAR
  106.   RecPack : RegPack;
  107.  
  108. Procedure WGET;  External;
  109.  
  110. Procedure WPUT;  External;
  111.  
  112.  
  113. Procedure Scroll_Page_Up;
  114. (* x,y,w,h,lines,attrib: BYTE *)
  115. BEGIN
  116.   recpack.ah := $06;
  117.   recpack.al := lines;
  118.   recpack.cl := x-1;   (* x upper left *)
  119.   recpack.ch := y-1;   (* y upper left *)
  120.   recpack.dl := x+w-2; (* x lower right *)
  121.   recpack.dh := y+h-2; (* y lower right *)
  122.   recpack.bh := attrib;
  123.   Intr($10,recpack);
  124. END;
  125.  
  126. Procedure Scroll_Page_Dn;
  127. (* x,y,w,h,lines,attrib: BYTE *)
  128. BEGIN
  129.   recpack.ah := $07;
  130.   recpack.al := lines;
  131.   recpack.cl := x-1;   (* x upper left *)
  132.   recpack.ch := y-1;   (* y upper left *)
  133.   recpack.dl := x+w-2; (* x lower right *)
  134.   recpack.dh := y+h-2; (* y lower right *)
  135.   recpack.bh := attrib;
  136.   Intr($10,recpack);
  137. END;
  138.  
  139.  
  140. Procedure Put_Cursor;
  141. (* (x,y: BYTE); *)
  142. BEGIN
  143.    recpack.ah := $02;  (* position cursor *)
  144.    recpack.dh := y - 1;
  145.    recpack.dl := x - 1;
  146.    recpack.bh := 0;  (* video page *)
  147.    Intr($10,recpack);
  148. END;
  149.  
  150. Procedure Get_Cursor;
  151. (* (VAR x,y: BYTE); *)
  152. BEGIN
  153.    recpack.ah := $03;  (* position cursor *)
  154.    recpack.bh := 0;    (* video page *)
  155.    Intr($10,recpack);
  156.    y := recpack.dh + 1;
  157.    x := recpack.dl + 1;
  158. END;
  159.  
  160. Procedure Get_Vattrib;
  161. (* (VAR vchar,vattrib: byte); *)
  162. BEGIN
  163.    recpack.ah := $08;  (* read attrib, char *)
  164.    recpack.bh := 0;    (* page numbert *)
  165.    Intr($10,recpack);
  166.    vchar := recpack.al;
  167.    vattrib := recpack.ah;
  168. END;
  169.  
  170.  
  171. Procedure Put_Vattrib;
  172. (* (vchar,vattrib: byte); *)
  173. BEGIN
  174.    recpack.ah := $09;  (* write  attrib, char *)
  175.    recpack.bh := 0;    (* video page *)
  176.    recpack.cx := 1;    (* 1 char to write *)
  177.    recpack.al := vchar;
  178.    recpack.bl := vattrib;
  179.    Intr($10,recpack);
  180. END;
  181.  
  182.  
  183. Function get_Vmode;
  184. (* INTEGER *)
  185. BEGIN
  186.   recpack.ax := $0F00;
  187.   Intr($10,recpack);
  188.   get_Vmode := recpack.ax mod 256;
  189. END; (* get_Vmode *)
  190.  
  191.   { ------------------- }
  192.  
  193. Function get_dos_ver_number;
  194. (* st255 *)
  195. VAR
  196.   mnrn,mjrn: INTEGER;
  197. begin
  198.   recpack.ax := $3000;   (* get dos ver number *)
  199.   msdos(recpack);
  200.   mnrn := recpack.ax shr 8;
  201.   mjrn := recpack.ax mod 256;
  202.   get_dos_ver_number := fns(mjrn) + '.' + fns(mnrn);
  203. end;
  204.  
  205.   { ------------------- }
  206.  
  207. Function get_date;
  208. (* st255 *)
  209. var
  210.   month,day : string[2];
  211.   year      : string[4];
  212.   dx,cx     : integer;
  213.   daynum    : INTEGER;
  214. begin
  215.   recpack.ax := $2a00;   (* get dos date *)
  216.   msdos(recpack);
  217.   with recpack do
  218.   begin
  219.     str(cx,year);
  220.     str(dx mod 256,day);
  221.     str(dx shr 8,month);
  222.     daynum := ax mod 256;
  223.   end;
  224.   get_date := fnzero(month,2) + '/' + fnzero(day,2) + '/' + fnzero(year,2);
  225. end;
  226.  
  227.   { ------------------- }
  228.  
  229. Function get_time;
  230. (* st255 *)
  231. var
  232.   hour,min,sec : string[2];
  233. begin
  234.   recpack.ax := $2c00;   (* get dos time *)
  235.   str(recpack.cx shr 8,hour);
  236.   str(recpack.cx mod 256,min);
  237.   str(recpack.dx shr 8,sec);
  238.   get_time := fnzero(hour,2) + ':' + fnzero(min,2) + ':' + fnzero(sec,2);
  239. end;
  240.  
  241.   { ------------------- }
  242.  
  243. Procedure Get_DTA;
  244. (* (VAR DTA_SEG,DTA_OFS: WORD); *)
  245. BEGIN
  246.    (* get dta *)
  247.    recpack.AX := $2F00;
  248.    MSDOS(recpack);
  249.    DTA_SEG := recpack.ES;
  250.    DTA_OFS := recpack.BX;
  251. END; (* GET_DTA *)
  252.  
  253.   { ------------------- }
  254.  
  255. Function Current_Drive;
  256. (* Integer *)
  257. BEGIN
  258.    recpack.AX := $1900;
  259.    MsDos(recpack);
  260.    current_drive := (recpack.ax mod 256);
  261. END;  
  262.  
  263.   { ------------------- }
  264.  
  265. Function Get_Cur_Dir;
  266. (* (cur_drive: INTEGER) : st255; *)
  267. VAR
  268.    user_memory: st255;
  269.    i: INTEGER;
  270. BEGIN
  271.    recpack.AX := $4700;
  272.    recpack.DS := seg(user_memory);
  273.    recpack.SI := ofs(user_memory)+1;
  274.    recpack.DX := cur_drive;
  275.    MSDOS(recpack);
  276.    IF (recpack.flags and 1) = 1 THEN begin
  277.      user_memory := 'ERROR';
  278.    end
  279.    ELSE begin
  280.      i := 1;
  281.      while user_memory[i] <> chr(0) DO begin
  282.         i := i + 1;
  283.      END;
  284.      user_memory[0] := chr(i-1);
  285.    END;
  286.    Get_Cur_Dir := user_memory;
  287. END;
  288.  
  289.   { ------------------- }
  290.  
  291. Procedure DirFile;
  292. (*  (first: INTEGER; search_str: st255; DTA_SEG,DTA_OFS: WORD; 
  293.      VAR found_str: st255; VAR attrib: INTEGER); *)
  294. VAR i,b: INTEGER;
  295.     fname: st255;
  296. BEGIN
  297.   fname := search_str + chr(0);
  298.   found_str := '';
  299.   IF first = 1 THEN begin
  300.  
  301.      (* search first *)
  302.      recpack.AX := $4E00;  (* find first matching *)
  303.      recpack.CX := attrib;
  304.      recpack.DS := Seg(fname[1]);
  305.      recpack.DX := Ofs(fname[1]);
  306.      MSDOS(recpack);
  307.      IF (recpack.flags AND 1) <> 1 THEN begin
  308.        attrib := MEM[DTA_SEG:DTA_OFS+21];
  309.        i := DTA_OFS + 30;
  310.        b := MEM[DTA_SEG:i];
  311.        WHILE (i < DTA_OFS+42) AND (b <> 0) DO begin
  312.          found_str := found_str + CHR(b);
  313.          i := i + 1;
  314.          b := MEM[DTA_SEG:i];
  315.        END;
  316.      end
  317.      ELSE begin
  318.        Found_str := 'EOF';
  319.      END;
  320.  
  321.   end
  322.   ELSE BEGIN
  323.      recpack.AX := $4F00;  (* find next matching *)
  324.      recpack.AX := recpack.AX XOR 1;  (* turn carry off *)
  325.      MSDOS(recpack);
  326.      IF (recpack.flags AND 1) <> 1 THEN begin
  327.        attrib := MEM[DTA_SEG:DTA_OFS+21];
  328.        i := DTA_OFS + 30;
  329.        b := MEM[DTA_SEG:i];
  330.        WHILE (i < DTA_OFS+42) AND (b <> 0) DO begin
  331.          found_str := found_str + CHR(b);
  332.          i := i + 1;
  333.          b := MEM[DTA_SEG:i];
  334.        END;
  335.      end
  336.      ELSE BEGIN
  337.         found_str := 'EOF';
  338.      END;
  339.   END;
  340. END;  (* DirFile *)
  341.  
  342.   { ------------------- }
  343.  
  344. Procedure DelFile;
  345. (* (fn: st255); *)
  346. VAR
  347.   fname: st255;
  348. BEGIN
  349.   fname := fn + CHR(0);
  350.   recpack.AX := $4100;
  351.   recpack.DS := Seg(fname[1]);
  352.   recpack.DX := Ofs(fname[1]);
  353.   MSDOS(recpack);
  354.   IF (recpack.flags AND 1) = 1 THEN begin
  355.    (* error deleting *)
  356.     WriteLn('Error :  ',fn);
  357.   END;
  358. END;
  359.  
  360.   { ------------------- }
  361.  
  362. Function ShiftState;
  363. (* (ss: INTEGER): BOOLEAN; *)
  364. BEGIN
  365.   recpack.AX := $0200;
  366.   Intr($16,recpack);
  367.   ShiftState := ((recpack.ax mod 256) and ss) = ss;
  368. END;
  369.  
  370.   { ------------------- }
  371.  
  372. Procedure Disk_Free;
  373. (* (Drive: WORD; VAR Disk_bytes, avail_bytes: LongInt); *)
  374. VAR
  375.   Avail_Clusters,Clusters_Drive,Bytes_Sector,Sectors_Cluster: LongInt;
  376. BEGIN
  377.   recpack.AX := $3600;
  378.   recpack.DX := Drive;
  379.   MsDos(recpack);
  380.   IF (RecPack.flags and 1) = 1 then begin
  381.     disk_bytes := -1;
  382.     avail_bytes := -1;
  383.   end
  384.   ELSE begin
  385.     Avail_Clusters := recpack.BX;
  386.     Clusters_Drive := recpack.DX;
  387.       Bytes_Sector := recpack.CX;
  388.    Sectors_Cluster := recpack.AX;
  389.    avail_bytes := Avail_Clusters * Sectors_Cluster * Bytes_Sector;
  390.    disk_bytes := clusters_drive * sectors_cluster * bytes_sector;
  391.   END;
  392.  
  393. END;
  394.  
  395.   { ------------------- }
  396.  
  397. Function DayOfWeek;
  398. (* (dstr: st255) : INTEGER; *)
  399. VAR month_num,
  400.      week_day,
  401.      year_num,
  402.      x3,x4,x5,
  403.      x6,x7,x8: INTEGER;
  404. BEGIN
  405.     month_num := fnval(copy(dstr,1,2));
  406.     week_day  := fnval(copy(dstr,4,2));
  407.     year_num  := fnval(copy(dstr,7,4));
  408.  
  409.     x4 := year_num - trunc(year_num / 28) * 28;
  410.     if x4 = 0
  411.       then
  412.         x4 := 28;
  413.     x5 := trunc((x4 - 1) / 4);
  414.     x6 := x4 - 1 - x5 * 4;
  415.     x4 := x5 * 5 - trunc(x5 * 5 / 7) * 7;
  416.     x5 := x4 + x6 - 7;
  417.     if x5 < 0
  418.      then
  419.        x5 := x4 + x6;
  420.     x4 := (month_num - 1) * 30;
  421.     x6 := trunc((month_num - 1) / 2);
  422.     x7 := month_num - 1 - x6 * 2;
  423.     x8 := x4 + x6 + x7;
  424.     if (x6 > 3) and (x7 = 0)
  425.       then
  426.         x8 := x8 + 1;
  427.  
  428.     if x6 <> 0
  429.       then
  430.         begin
  431.           if year_num <> trunc(year_num / 4) * 4
  432.            then
  433.              x4 := week_day + x8 - 2
  434.            else
  435.              x4 := week_day + x8 - 1;
  436.         end
  437.       else
  438.         x4 := week_day + x8;
  439.  
  440.     year_num := x4 - trunc(x4 / 7) * 7;
  441.     if year_num = 0
  442.       then
  443.         year_num := 7;
  444.     year_num := year_num - 1;
  445.     week_day := year_num + x5 - 7;
  446.     if week_day < 0
  447.       then
  448.         week_day := year_num + x5;
  449.     week_day := week_day + 1;
  450.  
  451.     DayOfWeek := week_day;
  452. END;
  453.  
  454.   { ------------------- }
  455.  
  456. Procedure ReadDTA;
  457. (*  (VAR disk_time,disk_date: INTEGER; DTA_SEG,DTA_OFS: WORD;
  458.      VAR DTA_attrib : WORD; dsize: LongInt); *)
  459. VAR
  460.   i: INTEGER;
  461.   ds: ARRAY[1..4] OF LongInt;
  462. BEGIN
  463.    disk_time := MEM[DTA_SEG:DTA_OFS+22]+MEM[DTA_SEG:DTA_OFS+23]*256;
  464.    disk_date := MEM[DTA_SEG:DTA_OFS+24]+MEM[DTA_SEG:DTA_OFS+25]*256;
  465.    DTA_attrib := MEM[DTA_SEG:DTA_OFS+21];
  466.    FOR i := 26 to 29 DO begin
  467.      ds[i-25] := MEM[DTA_SEG:DTA_OFS+i];
  468.    END;
  469.    dsize := (ds[1] + ds[2]*256) + (ds[3]+ds[4]*256) * 65536;
  470. END;
  471.  
  472.   { ------------------- }
  473.  
  474. Procedure Do_DTA_Date;
  475. (*  (disk_date,disk_time: INTEGER; DTA_SEG,DTA_OFS: WORD;
  476.      VAR DTA_Date: dta_date_type; VAR dta_time: dta_time_type); *)
  477. BEGIN
  478.   DTA_date.year := (disk_date shr 9) + 1980;
  479.   DTA_date.month := (disk_date shr 5) and 15;
  480.   DTA_date.day := disk_date and 31;
  481.   DTA_time.hour := (disk_time shr 11);
  482.   DTA_time.min  := (disk_time shr 5) and 63;
  483. END;  
  484.  
  485. (*  week_day := DayOfWeek(fns_z(DTA_date.month)+'/'+fns_z(DTA_date.day)+'/'+fns(DTA_date.year)); *)
  486.  
  487.   { ------------------- }
  488.  
  489. Procedure Open_File;
  490. (*  (f:st255; omode: INTEGER; VAR fhandle: INTEGER); *)
  491. VAR
  492.   fname: st255;
  493. BEGIN
  494.     fname := f+chr(0);
  495.     Recpack.AX := $3D00 + omode;
  496.     Recpack.DX := OFS(fname)+1;  (* skip [0] *)
  497.     Recpack.DS := SEG(fname);
  498.     MsDos(Dos.Registers(RecPack));
  499.     IF (RecPack.flags AND 1) <> 1 THEN begin
  500.        fhandle := RecPack.AX;
  501.     end
  502.     ELSE begin
  503.        fhandle := -1;
  504.        WriteLn('error opening file ',f,'  = ',recpack.ax);
  505.     END;
  506. END; (* Open_File *)
  507.  
  508.   { ------------------- }
  509.  
  510. Procedure Close_File;
  511. (*  (fhandle: INTEGER); *)
  512. BEGIN
  513.     RecPack.AX := $3E00;
  514.     RecPack.BX := fhandle;
  515.     MsDos(Dos.Registers(RecPack));
  516. END; (* Close_File *)
  517.  
  518.   { ------------------- }
  519.  
  520. Procedure LSeek;
  521. (*  (fhandle,smode: INTEGER; flen: LongInt); *)
  522. BEGIN
  523.     RecPack.AX := $4200 + smode;
  524.     RecPack.CX := flen div 65536;
  525.     RecPack.DX := flen mod 65536;
  526.     RecPack.BX := fhandle;
  527.     MsDos(Dos.Registers(RecPack));
  528. END; (* LSeek *)
  529.  
  530.   { ------------------- }
  531.  
  532. Procedure Write_File;
  533. (*  (fhandle,buf_seg,buf_adr,bytes: INTEGER); *)
  534. BEGIN
  535.     RecPack.AX := $4000;
  536.     RecPack.BX := fhandle;
  537.     RecPack.CX := bytes;
  538.     RecPack.DX := Word_Int(buf_adr);
  539.     RecPack.DS := Word_Int(buf_seg);
  540.     MsDos(Dos.Registers(RecPack));
  541. END; (* Write_File *)
  542.  
  543.   { ------------------- }
  544.  
  545. Procedure SetFileTime;
  546. (* (fhandle,time_word,date_word: INTEGER); *)
  547. BEGIN
  548.   recpack.ax := $5701;
  549.   recpack.bx := fhandle;
  550.   recpack.cx := time_word;
  551.   recpack.dx := date_word;
  552.   MsDos(recpack);
  553. END;  (* SetFileTime *)
  554.  
  555.   { ------------------- }
  556.  
  557. Procedure GetFileTime;
  558. (*  (fhandle,time_word,date_word: INTEGER); *)
  559. BEGIN
  560.   recpack.ax := $5700;
  561.   recpack.bx := fhandle;
  562.   MsDos(recpack);
  563.   time_word := recpack.cx;
  564.   date_word := recpack.dx;
  565. END; (* GetFileTime *)
  566.  
  567.   { ------------------- }
  568.  
  569. Procedure F_Copy;
  570. (*  (source,dest: st255; disk_time,disk_date: INTEGER; flen: LongInt); *)
  571. CONST
  572.   BufSize = 1024;
  573. VAR
  574.   a,b: FILE;
  575.   Buffer: ARRAY[1..BufSize] OF BYTE;
  576.   RecsRead: INTEGER;
  577.   fhandle,date_word,time_word: INTEGER;
  578. BEGIN
  579.   Assign(a,source);
  580.   Assign(b,dest);
  581.   Reset(a);
  582.   Rewrite(b);
  583.   REPEAT
  584.     BlockRead(a,Buffer,BufSize DIV 128,RecsRead);
  585.     BlockWrite(b,Buffer,RecsRead);
  586.   UNTIL RecsRead = 0;
  587.   Close(a);
  588.   Close(b);
  589.  
  590.   Open_File(dest,2,fhandle);
  591.   IF fhandle <> -1 THEN begin
  592.     Lseek(fhandle,0,flen);
  593.     IF (RecPack.flags AND 1) <> 1 THEN begin
  594.        Write_File(fhandle,-1,0,0);
  595.        SetFileTime(fhandle,disk_time,disk_date);
  596.        Close_File(fhandle);
  597.     end
  598.     ELSE begin
  599.       Close_File(fhandle);
  600.     END;
  601.   END;
  602. END; (* Fcopy *)
  603.  
  604.  
  605. Function Mem_Free;
  606. (*  : LongInt; *)
  607. BEGIN
  608.   recpack.AX := $4800;
  609.   recpack.BX := $FFFF;
  610.   MsDos(RecPack);
  611.   Mem_Free := recpack.BX * 16;
  612. END;
  613.  
  614. Function Mem_Installed;
  615. (*  : LongInt; *)
  616. VAR
  617.   kblocks : LongInt;
  618. BEGIN
  619.   Intr($12,RecPack);
  620.   kblocks := RecPack.ax;
  621.   Mem_Installed := kblocks * 1024;
  622. END;
  623.  
  624.  
  625. END.
  626.  
  627.