home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / DPSX / TOOL-PAS.ZIP / MDOSIO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-03-26  |  14.5 KB  |  582 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*
  14.  * mdosio - library for interface to DOS v3 file access functions (3-1-89)
  15.  *
  16.  *)
  17.  
  18. {$i prodef.inc}
  19.  
  20. unit MDosIO;
  21.  
  22. interface
  23.  
  24.    uses Dos,debugs;
  25.  
  26.    type
  27.       dos_filename = string[64];
  28.       dos_handle   = word;
  29.  
  30.       long_integer = record
  31.          lsw: word;
  32.          msw: word;
  33.       end;
  34.  
  35.       seek_modes = (seek_start {0},
  36.                     seek_cur   {1},
  37.                     seek_end   {2});
  38.  
  39.       open_modes = (open_read  {h40},     {deny_nothing, allow_read}
  40.                     open_write {h41},     {deny_nothing, allow_write}
  41.                     open_update{h42});    {deny_nothing, allow_read+write}
  42.  
  43.       dos_time_functions = (time_get,
  44.                             time_set);
  45.  
  46.    const
  47.       dos_error   = $FFFF; {file handle after an error}
  48.       min_handle  = 2;
  49.       max_handle  = 10;
  50.       dos_retry_count:  integer = 0;
  51.  
  52.    var
  53.       dos_regs:         registers;
  54.       dos_name:         dos_filename;
  55.       dos_write_err:    boolean;
  56.       dos_names:        array[min_handle..max_handle] of dos_filename;
  57.  
  58.    type
  59.       dos_functions = (_open,  _creat,
  60.                        _close, _times,
  61.                        _read,  _write,
  62.                        _rseek, _lseek,
  63.                        _lock,  _unlock);
  64.  
  65.    const
  66.       function_names:  array[dos_functions] of string[5] =
  67.                       ('OPEN', 'CREAT',
  68.                        'CLOSE','TIMES',
  69.                        'READ', 'WRITE',
  70.                        'RSEEK','LSEEK',
  71.                        'LOCK', 'UNLCK');
  72.                        
  73.  
  74.    procedure dos_check_error(fun: dos_functions);
  75.  
  76.    procedure dos_call(fun: dos_functions);
  77.  
  78.    function dos_open(name:      dos_filename;
  79.                      mode:      open_modes):  dos_handle;
  80.  
  81.    function dos_create(name:    dos_filename): dos_handle;
  82.  
  83.    function dos_read( handle:   dos_handle;
  84.                       var       buffer;
  85.                       bytes:    word): word;
  86.  
  87.    procedure dos_write(handle:  dos_handle;
  88.                        var      buffer;
  89.                        bytes:   word);
  90.  
  91.    procedure dos_lseek(handle:  dos_handle;
  92.                        offset:  longint;
  93.                        method:  seek_modes);
  94.  
  95.    procedure dos_rseek(handle:  dos_handle;
  96.                        recnum:  word;
  97.                        recsiz:  word;
  98.                        method:  seek_modes);
  99.  
  100.    function dos_tell: longint;
  101.  
  102.    procedure dos_find_eof(fd:   dos_handle);
  103.  
  104.    procedure dos_close(handle:  dos_handle);
  105.  
  106.    procedure dos_unlink(name:   dos_filename);
  107.  
  108.    procedure dos_file_times(fd:       dos_handle;
  109.                             func:     dos_time_functions;
  110.                             var time: word;
  111.                             var date: word);
  112.  
  113.    function dos_jdate(time,date: word): longint;
  114.  
  115.    function dos_exists(name: dos_filename): boolean;
  116.  
  117.    function dos_lock(handle:  dos_handle;
  118.                      offset:  longint;
  119.                      bytes:   word): boolean;
  120.  
  121.    procedure dos_unlock(handle:  dos_handle;
  122.                         offset:  longint;
  123.                         bytes:   word);
  124.  
  125.    procedure dos_time(var ms: longint);
  126.  
  127.    procedure dos_delay(ms: longint);
  128.  
  129.  
  130. implementation
  131.  
  132. (* -------------------------------------------------------- *)
  133. procedure dos_check_error(fun: dos_functions);
  134. var
  135.    msg:  string[40];
  136. begin
  137.    dos_regs.es := dos_regs.ax;   {save possible error code}
  138.  
  139.    if (dos_regs.flags and Fcarry) <> 0 then
  140.    begin
  141.       case dos_regs.ax of
  142.          2:   msg := 'FILE NOT FOUND';
  143.          3:   msg := 'DIR NOT FOUND';
  144.         {4:   msg := 'TOO MANY OPEN FILES';}
  145.          5:   msg := 'ACCESS DENIED';
  146.          else str(dos_regs.ax,msg);
  147.       end;
  148. {$I-}
  149.       writeln(debugfd^,' DOS error ['+msg+'] on file ['+dos_name+'] during ['+function_names[fun]+']');
  150. {$i+}
  151.       dos_regs.ax := dos_error;     {return standard failure code}
  152.       dos_delay(3000);
  153.    end;
  154. end;
  155.  
  156.  
  157. (* -------------------------------------------------------- *)
  158. procedure dos_call(fun: dos_functions);
  159. begin
  160.    msdos(dos_regs);
  161.    dos_check_error(fun);
  162. end;
  163.  
  164.  
  165. (* -------------------------------------------------------- *)
  166. procedure prepare_dos_name(var name: dos_filename);
  167. begin
  168.    while (name <> '') and (name[length(name)] <= ' ') do
  169.       dec(name[0]);
  170.  
  171. {  if name = '' then
  172.       name := 'Nul'; }
  173.  
  174.    dos_name := name;
  175.    dos_name[length(dos_name)+1] := #0;
  176.    dos_regs.ds := seg(dos_name);
  177.    dos_regs.dx := ofs(dos_name)+1;
  178. end;
  179.  
  180.  
  181. (* -------------------------------------------------------- *)
  182. function dos_open(name:    dos_filename;
  183.                   mode:    open_modes):  dos_handle;
  184. var
  185.    try: integer;
  186.  
  187. begin
  188.  
  189. {$IFDEF DEBUGGING}
  190.    if debugging then
  191.       writeln(debugfd^,'dos_open(',name,',',ord(mode),')');
  192. {$ENDIF}
  193.  
  194.    dos_open := dos_error;
  195.    for try := 1 to dos_retry_count do
  196.    begin
  197.       dos_regs.ax := $3d00 + ord(mode);
  198.       if lo(DosVersion) >= 3 then
  199.          inc(dos_regs.ax,$40);
  200.  
  201.       prepare_dos_name(name);
  202.       if name = '' then
  203.          exit;
  204.  
  205.       msdos(dos_regs);
  206.  
  207.       {return to caller immediately if no errors were detected}
  208.       if (dos_regs.flags and Fcarry) = 0 then
  209.       begin
  210.          if (dos_regs.ax >= min_handle) and (dos_regs.ax <= max_handle) then
  211.             dos_names[dos_regs.ax] := name;
  212.  
  213.          dos_open := dos_regs.ax;
  214.          exit;
  215.       end;
  216.  
  217.       {return to caller if file-not-found}
  218.       if (dos_regs.ax = 2) then
  219.          exit;
  220.  
  221.       {report other errors and attempt to retry}
  222.       dos_check_error(_open);
  223.  
  224.       {return to caller if dir-not-found}
  225.       if (dos_regs.es = 3) then
  226.          exit;
  227.    end;
  228.  
  229. end;
  230.  
  231.  
  232. (* -------------------------------------------------------- *)
  233. function dos_create(name:    dos_filename): dos_handle;
  234. begin
  235.    dos_regs.ax := $3c00;
  236.    prepare_dos_name(name);
  237.    if name = '' then
  238.    begin
  239.       dos_create := dos_error;
  240.       exit;
  241.    end;
  242.  
  243. {$IFDEF DEBUGGING}
  244.    if debugging then
  245.       writeln(debugfd^,'dos_create(',name,')');
  246. {$ENDIF}
  247.  
  248.    dos_regs.cx := 0;   {attrib}
  249.    dos_call(_creat);
  250.    if (dos_regs.ax >= min_handle) and (dos_regs.ax <= max_handle) then
  251.       dos_names[dos_regs.ax] := name;
  252.    dos_create := dos_regs.ax;
  253. end;
  254.  
  255.  
  256. (* -------------------------------------------------------- *)
  257. function dos_read( handle:  dos_handle;
  258.                    var      buffer;
  259.                    bytes:   word): word;
  260. var
  261.    try:  integer;
  262.  
  263. begin
  264.    for try := 1 to dos_retry_count do
  265.    begin
  266.       dos_regs.ax := $3f00;
  267.       dos_regs.bx := handle;
  268.       dos_regs.cx := bytes;
  269.       dos_regs.ds := seg(buffer);
  270.       dos_regs.dx := ofs(buffer);
  271.       msdos(dos_regs);
  272.       dos_read := dos_regs.ax;
  273.  
  274.       {return to caller immediately if no errors were detected}
  275.       if (dos_regs.flags and Fcarry) = 0 then
  276.          exit;
  277.  
  278.       dos_read := dos_error;
  279.  
  280.       {report other errors and attempt to retry}
  281.       dos_check_error(_read);
  282.  
  283.       {return to caller if not access-denied}
  284.       if (dos_regs.es <> 5) then
  285.          exit;
  286.    end;
  287.  
  288. (************
  289.    dos_regs.ax := $3f00;
  290.    dos_regs.bx := handle;
  291.    dos_regs.cx := bytes;
  292.    dos_regs.ds := seg(buffer);
  293.    dos_regs.dx := ofs(buffer);
  294.    dos_call(_read);
  295.    dos_read := dos_regs.ax;
  296. ***********)
  297. end;
  298.  
  299.  
  300. (* -------------------------------------------------------- *)
  301. procedure dos_write(handle:  dos_handle;
  302.                     var      buffer;
  303.                     bytes:   word);
  304. begin
  305. {if bytes=0 then writeln('DOS: write 0 bytes!!');}
  306.  
  307.    dos_regs.ax := $4000;
  308.    dos_regs.bx := handle;
  309.    dos_regs.cx := bytes;
  310.    dos_regs.ds := seg(buffer);
  311.    dos_regs.dx := ofs(buffer);
  312.    dos_call(_write);
  313.    dos_regs.cx := bytes;
  314.    dos_write_err := dos_regs.ax <> dos_regs.cx;
  315. end;
  316.  
  317.  
  318. (* -------------------------------------------------------- *)
  319. procedure dos_lseek(handle:  dos_handle;
  320.                     offset:  longint;
  321.                     method:  seek_modes);
  322. var
  323.    pos:  long_integer absolute offset;
  324.  
  325. begin
  326.    dos_regs.ax := $4200 + ord(method);
  327.    dos_regs.bx := handle;
  328.    dos_regs.cx := pos.msw;
  329.    dos_regs.dx := pos.lsw;
  330.    dos_call(_lseek);
  331. end;
  332.  
  333.  
  334. (* -------------------------------------------------------- *)
  335. procedure dos_rseek(handle:  dos_handle;
  336.                     recnum:  word;
  337.                     recsiz:  word;
  338.                     method:  seek_modes);
  339. var
  340.    offset: longint;
  341.    pos:    long_integer absolute offset;
  342.  
  343. begin
  344.    offset := longint(recnum) * longint(recsiz);
  345.    dos_regs.ax := $4200 + ord(method);
  346.    dos_regs.bx := handle;
  347.    dos_regs.cx := pos.msw;
  348.    dos_regs.dx := pos.lsw;
  349.    dos_call(_rseek);
  350. end;
  351.  
  352.  
  353. (* -------------------------------------------------------- *)
  354. function dos_tell: longint;
  355.   {call immediately after dos_lseek or dos_rseek}
  356. var
  357.    pos:  long_integer;
  358.    li:   longint absolute pos;
  359. begin
  360.    pos.lsw := dos_regs.ax;
  361.    pos.msw := dos_regs.dx;
  362.    dos_tell := li;
  363. end;
  364.  
  365.  
  366. (* -------------------------------------------------------- *)
  367. procedure dos_find_eof(fd: dos_handle);
  368.    {find end of file, skip backward over ^Z eof markers}
  369. var
  370.    b: char;
  371.    n: word;
  372.    i: word;
  373.    p: longint;
  374.    temp: array[1..128] of char;
  375.  
  376. begin
  377.    dos_lseek(fd,0,seek_end);
  378.    p := dos_tell-1;
  379.    if p < 0 then
  380.       exit;
  381.  
  382.    p := p and $FFFF80;   {round to last 'sector'}
  383.    {search forward for the eof marker}
  384.    dos_lseek(fd,p,seek_start);
  385.    n := dos_read(fd,temp,sizeof(temp));
  386.    i := 1;
  387.  
  388.    while (i <= n) and (temp[i] <> ^Z) do
  389.    begin
  390.       inc(i);
  391.       inc(p);
  392.    end;
  393.  
  394.    {backup to overwrite the eof marker}
  395.    dos_lseek(fd,p,seek_start);
  396. end;
  397.  
  398.  
  399. (* -------------------------------------------------------- *)
  400. procedure dos_close(handle:  dos_handle);
  401. begin
  402. {$IFDEF DEBUGGING}
  403.    if debugging then
  404.       if (handle >= min_handle) and (handle <= max_handle) then
  405.          writeln(debugfd^,'dos_close(',dos_names[handle],')')
  406.       else
  407.          writeln(debugfd^,'dos_close(invalid #',handle,')');
  408. {$ENDIF}
  409.  
  410.    dos_regs.ax := $3e00;
  411.    dos_regs.bx := handle;
  412.    msdos(dos_regs);  {dos_call;}
  413. end;
  414.  
  415.  
  416. (* -------------------------------------------------------- *)
  417. procedure dos_unlink(name:    dos_filename);
  418.    {delete a file, no error message if file doesn't exist}
  419. begin
  420.    dos_regs.ax := $4100;
  421.    prepare_dos_name(name);
  422.    if name = '' then
  423.       exit;
  424.    msdos(dos_regs);
  425.  
  426. {$IFDEF DEBUGGING}
  427.    if (dos_regs.flags and Fcarry) = 0 then
  428.       if debugging then
  429.          writeln(debugfd^,'dos_unlink(',name,')');
  430. {$ENDIF}
  431. end;
  432.  
  433.  
  434. (* -------------------------------------------------------- *)
  435. procedure dos_file_times(fd:       dos_handle;
  436.                          func:     dos_time_functions;
  437.                          var time: word;
  438.                          var date: word);
  439. begin
  440.    dos_regs.ax := $5700 + ord(func);
  441.    dos_regs.bx := fd;
  442.    dos_regs.cx := time;
  443.    dos_regs.dx := date;
  444.    dos_call(_times);
  445.    time := dos_regs.cx;
  446.    date := dos_regs.dx;
  447. end;
  448.  
  449.  
  450. (* -------------------------------------------------------- *)
  451. function dos_jdate(time,date: word): longint;
  452. begin
  453.  
  454. (***
  455.      write(' d=',date:5,' t=',time:5,' ');
  456.      write('8',   (date shr 9) and 127:1); {year}
  457.      write('/',   (date shr 5) and  15:2); {month}
  458.      write('/',   (date      ) and  31:2); {day}
  459.      write(' ',   (time shr 11) and 31:2); {hour}
  460.      write(':',   (time shr  5) and 63:2); {minute}
  461.      write(':',   (time shl  1) and 63:2); {second}
  462.      writeln(' j=', (longint(date) shl 16) + longint(time));
  463.  ***)
  464.  
  465.    dos_jdate := (longint(date) shl 16) + longint(time);
  466. end;
  467.  
  468.  
  469. (* -------------------------------------------------------- *)
  470. function dos_exists(name: dos_filename): boolean;
  471. var
  472.    DirInfo:     SearchRec;
  473.  
  474. begin
  475.    dos_exists := false;
  476.    prepare_dos_name(name);
  477.    if name = '' then
  478.       exit;
  479.  
  480.    FindFirst(dos_name,AnyFile,DirInfo);
  481.  
  482. { IFDEF DEBUGGING}
  483.    if debugging then
  484.       writeln(debugfd^,'dos_exists(',name,')? -> ',DosError=0);
  485. { ENDIF}
  486.  
  487.    if DosError = 0 then
  488.       dos_exists := true;
  489. end;
  490.  
  491.  
  492. (* -------------------------------------------------------- *)
  493. function dos_lock(handle:  dos_handle;
  494.                   offset:  longint;
  495.                   bytes:   word): boolean;
  496. var
  497.    pos:    long_integer absolute offset;
  498.  
  499. begin
  500.    dos_regs.ax := $5c00;
  501.    dos_regs.bx := handle;
  502.    dos_regs.cx := pos.msw;
  503.    dos_regs.dx := pos.lsw;
  504.    dos_regs.si := 0;
  505.    dos_regs.di := bytes;
  506.    msdos(dos_regs);
  507.  
  508.    dos_lock := false;
  509.    if ((dos_regs.flags and Fcarry) = 0) or (dos_regs.ax = 1) then
  510.       dos_lock := true
  511.    else
  512.       case dos_regs.ax of
  513.          5,    {access denied}
  514.          32,   {sharing violation}
  515.          33:   {lock violation}
  516.             ;
  517.          else
  518.             dos_check_error(_lock);
  519.       end;
  520. end;
  521.  
  522.  
  523. (* -------------------------------------------------------- *)
  524. procedure dos_unlock(handle:  dos_handle;
  525.                      offset:  longint;
  526.                      bytes:   word);
  527. var
  528.    pos:    long_integer absolute offset;
  529.  
  530. begin
  531.    dos_regs.ax := $5c01;
  532.    dos_regs.bx := handle;
  533.    dos_regs.cx := pos.msw;
  534.    dos_regs.dx := pos.lsw;
  535.    dos_regs.si := 0;
  536.    dos_regs.di := bytes;
  537.    msdos(dos_regs);
  538.  
  539.    if (dos_regs.flags and Fcarry) <> 0 then
  540.    case dos_regs.ax of
  541.       1,    {invalid function}
  542.       5,    {access denied}
  543.       32,   {sharing violation}
  544.       33:   {lock violation}
  545.          ;
  546.       else
  547.          dos_check_error(_unlock);
  548.    end;
  549. end;
  550.  
  551.  
  552. (* -------------------------------------------------------- *)
  553. procedure dos_time(var ms: longint);
  554. var
  555.    reg:  registers;
  556. begin
  557.    reg.ax := 0;
  558.    intr($1a,reg);
  559.    ms := ((reg.cx shl 16) + reg.dx) * 55;
  560. end;
  561.  
  562.  
  563. (* -------------------------------------------------------- *)
  564. procedure dos_delay(ms: longint);
  565. var
  566.    time,start:  longint;
  567. begin
  568.    dos_time(start);
  569.    repeat
  570.       dos_time(time);
  571.    until (time > (start+ms)) or (time < start);
  572. end;
  573.  
  574.  
  575. (* -------------------------------------------------------- *)
  576. begin
  577.    val(GetEnv('RETRY_COUNT'),dos_retry_count,dos_regs.ax);
  578.    if dos_retry_count = 0 then
  579.       dos_retry_count := 5;
  580. end.
  581.  
  582.