home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FAQ-S.ZIP / MYCOMMAN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-10-13  |  12.9 KB  |  488 lines
  1. {$I+,N-,V-,B-,S-,R-,D-,L-}
  2.  
  3.  
  4. unit Mycomman;
  5.  
  6. interface
  7.  
  8.    uses crt,dos,
  9.    gentypes,configrt,modem,statret,gensubs,subs1,subs2,mainr2;
  10.  
  11.  
  12.    type
  13.       pointer_rec = record
  14.          offset:  word;
  15.          segment: word;
  16.       end;
  17.  
  18.    type
  19.       dos_filename = string[64];
  20.       dos_handle   = word;
  21.  
  22.       long_integer = record
  23.          lsw: word;
  24.          msw: word;
  25.       end;
  26.  
  27.       seek_modes = (seek_start {0},
  28.                     seek_cur   {1},
  29.                     seek_end   {2});
  30.  
  31.       open_modes = (open_read  {h40},
  32.                     open_write {h41},
  33.                     open_update{h42});
  34.  
  35.       dos_time_functions = (time_get,
  36.                             time_set);
  37.  
  38.    const
  39.       dos_error    = $FFFF;
  40.  
  41.    var
  42.       dos_regs:     registers;
  43.       dos_name:     dos_filename;
  44.  
  45.  
  46.    procedure dos_call;
  47.  
  48.    function dos_open(name:      dos_filename;
  49.                      mode:      open_modes):  dos_handle;
  50.  
  51.    function dos_create(name:    dos_filename): dos_handle;
  52.  
  53.    function dos_read( handle:   dos_handle;
  54.                       var       buffer;
  55.                       bytes:    word): word;
  56.  
  57.    procedure dos_write(handle:  dos_handle;
  58.                        var      buffer;
  59.                        bytes:   word);
  60.  
  61.    function dos_write_failed:   boolean;
  62.  
  63.    procedure dos_lseek(handle:  dos_handle;
  64.                        offset:  longint;
  65.                        method:  seek_modes);
  66.  
  67.    procedure dos_rseek(handle:  dos_handle;
  68.                        recnum:  word;
  69.                        recsiz:  word;
  70.                        method:  seek_modes);
  71.  
  72.    function dos_tell: longint;
  73.  
  74.    procedure dos_find_eof(fd:   dos_handle);
  75.  
  76.    procedure dos_close(handle:  dos_handle);
  77.  
  78.    procedure dos_unlink(name:   dos_filename);
  79.  
  80.    procedure dos_file_times(fd:       dos_handle;
  81.                             func:     dos_time_functions;
  82.                             var time: word;
  83.                             var date: word);
  84.  
  85.    function dos_jdate(time,date: word): longint;
  86.  
  87.    function dos_exists(name: dos_filename): boolean;
  88.  
  89.    procedure discon;
  90.  
  91.    procedure allstatus;
  92.  
  93.    function dos_maxavail: longint;
  94.  
  95.    procedure dos_getmem(var ptrvar; size: word);
  96.  
  97.    procedure dos_freemem(var ptrvar);
  98.  
  99.  
  100.  
  101. implementation
  102.  
  103. procedure dos_call;
  104. var
  105.    msg:  string;
  106. begin
  107.    msdos(dos_regs);
  108.  
  109.    if (dos_regs.flags and Fcarry) <> 0 then
  110.    begin
  111.       case dos_regs.ax of
  112.          2:   msg := 'file not found';
  113.          3:   msg := 'dir not found';
  114.          4:   msg := 'too many open files';
  115.          5:   msg := 'access denied';
  116.          else str(dos_regs.ax,msg);
  117.       end;
  118. {$I-}
  119.       writeln(' DOS error [',msg,'] on file [',dos_name,'] ');
  120. {$i+}
  121.       dos_regs.ax := dos_error;
  122.    end;
  123. end;
  124.  
  125.  
  126. procedure prepare_dos_name(name: dos_filename);
  127. begin
  128.    while (name <> '') and (name[length(name)] <= ' ') do
  129.       dec(name[0]);
  130.    if name = '' then
  131.       name := 'Nul';
  132.    dos_name := name;
  133.    dos_name[length(dos_name)+1] := #0;
  134.    dos_regs.ds := seg(dos_name);
  135.    dos_regs.dx := ofs(dos_name)+1;
  136. end;
  137.  
  138.  
  139. function dos_open(name:    dos_filename;
  140.                   mode:    open_modes):  dos_handle;
  141. var
  142.    try: integer;
  143. const
  144.    retry_count = 3;
  145.  
  146. begin
  147.    for try := 1 to retry_count do
  148.    begin
  149.       dos_regs.ax := $3d40 + ord(mode);
  150.       prepare_dos_name(name);
  151.       msdos(dos_regs);
  152.  
  153.       if (dos_regs.flags and Fcarry) = 0 then
  154.       begin
  155.          dos_open := dos_regs.ax;
  156.          exit;
  157.       end;
  158.    end;
  159.  
  160.    dos_open := dos_error;
  161. end;
  162.  
  163.  
  164. function dos_create(name:    dos_filename): dos_handle;
  165. begin
  166.    dos_regs.ax := $3c00;
  167.    prepare_dos_name(name);
  168.    dos_regs.cx := 0;   {attrib}
  169.    dos_call;
  170.    dos_create := dos_regs.ax;
  171. end;
  172.  
  173.  
  174. function dos_read( handle:  dos_handle;
  175.                    var      buffer;
  176.                    bytes:   word): word;
  177. begin
  178.    dos_regs.ax := $3f00;
  179.    dos_regs.bx := handle;
  180.    dos_regs.cx := bytes;
  181.    dos_regs.ds := seg(buffer);
  182.    dos_regs.dx := ofs(buffer);
  183.    dos_call;
  184.    dos_read := dos_regs.ax;
  185. end;
  186.  
  187.  
  188. procedure dos_write(handle:  dos_handle;
  189.                     var      buffer;
  190.                     bytes:   word);
  191. begin
  192.    dos_regs.ax := $4000;
  193.    dos_regs.bx := handle;
  194.    dos_regs.cx := bytes;
  195.    dos_regs.ds := seg(buffer);
  196.    dos_regs.dx := ofs(buffer);
  197.    dos_call;
  198.    dos_regs.cx := bytes;
  199. end;
  200.  
  201. function dos_write_failed: boolean;
  202. begin
  203.    dos_write_failed := dos_regs.ax <> dos_regs.cx;
  204. end;
  205.  
  206.  
  207. procedure dos_lseek(handle:  dos_handle;
  208.                     offset:  longint;
  209.                     method:  seek_modes);
  210. var
  211.    pos:  long_integer absolute offset;
  212.  
  213. begin
  214.    dos_regs.ax := $4200 + ord(method);
  215.    dos_regs.bx := handle;
  216.    dos_regs.cx := pos.msw;
  217.    dos_regs.dx := pos.lsw;
  218.    dos_call;
  219. end;
  220.  
  221.  
  222. procedure dos_rseek(handle:  dos_handle;
  223.                     recnum:  word;
  224.                     recsiz:  word;
  225.                     method:  seek_modes);
  226. var
  227.    offset: longint;
  228.    pos:    long_integer absolute offset;
  229.  
  230. begin
  231.    offset := longint(recnum) * longint(recsiz);
  232.    dos_regs.ax := $4200 + ord(method);
  233.    dos_regs.bx := handle;
  234.    dos_regs.cx := pos.msw;
  235.    dos_regs.dx := pos.lsw;
  236.    dos_call;
  237. end;
  238.  
  239.  
  240. function dos_tell: longint;
  241.   {call immediately after dos_lseek or dos_rseek}
  242. var
  243.    pos:  long_integer;
  244.    li:   longint absolute pos;
  245. begin
  246.    pos.lsw := dos_regs.ax;
  247.    pos.msw := dos_regs.dx;
  248.    dos_tell := li;
  249. end;
  250.  
  251.  
  252. procedure dos_find_eof(fd: dos_handle);
  253.    {find end of file, skip backward over ^Z eof markers}
  254. var
  255.    b: char;
  256.    n: word;
  257.    i: word;
  258.    p: longint;
  259.    temp: array[1..128] of char;
  260.  
  261. begin
  262.    dos_lseek(fd,0,seek_end);
  263.    p := dos_tell-1;
  264.    if p < 0 then
  265.       exit;
  266.  
  267.    p := p and $FFFF80;
  268.    {search forward for the eof marker}
  269.    dos_lseek(fd,p,seek_start);
  270.    n := dos_read(fd,temp,sizeof(temp));
  271.    i := 1;
  272.  
  273.    while (i <= n) and (temp[i] <> ^Z) do
  274.    begin
  275.       inc(i);
  276.       inc(p);
  277.    end;
  278.  
  279.    {backup to overwrite the eof marker}
  280.    dos_lseek(fd,p,seek_start);
  281. end;
  282.  
  283.  
  284. procedure dos_close(handle:  dos_handle);
  285. begin
  286.    dos_regs.ax := $3e00;
  287.    dos_regs.bx := handle;
  288.    msdos(dos_regs);  {dos_call;}
  289. end;
  290.  
  291.  
  292. procedure dos_unlink(name:    dos_filename);
  293.    {delete a file, no error message if file doesn't exist}
  294. begin
  295.    dos_regs.ax := $4100;
  296.    prepare_dos_name(name);
  297.    msdos(dos_regs);
  298. end;
  299.  
  300.  
  301. procedure dos_file_times(fd:       dos_handle;
  302.                          func:     dos_time_functions;
  303.                          var time: word;
  304.                          var date: word);
  305. begin
  306.    dos_regs.ax := $5700 + ord(func);
  307.    dos_regs.bx := fd;
  308.    dos_regs.cx := time;
  309.    dos_regs.dx := date;
  310.    dos_call;
  311.    time := dos_regs.cx;
  312.    date := dos_regs.dx;
  313. end;
  314.  
  315.  
  316. function dos_jdate(time,date: word): longint;
  317. begin
  318.  
  319. (***
  320.      write(' d=',date:5,' t=',time:5,' ');
  321.      write('8',   (date shr 9) and 127:1); {year}
  322.      write('/',   (date shr 5) and  15:2); {month}
  323.      write('/',   (date      ) and  31:2); {day}
  324.      write(' ',   (time shr 11) and 31:2); {hour}
  325.      write(':',   (time shr  5) and 63:2); {minute}
  326.      write(':',   (time shl  1) and 63:2); {second}
  327.      writeln(' j=', (longint(date) shl 16) + longint(time));
  328.  ***)
  329.  
  330.    dos_jdate := (longint(date) shl 16) + longint(time);
  331. end;
  332.  
  333.  
  334. function dos_exists(name: dos_filename): boolean;
  335. var
  336.    DirInfo:     SearchRec;
  337.  
  338. begin
  339.    prepare_dos_name(name);
  340.    FindFirst(dos_name,$21,DirInfo);
  341.    if (DosError <> 0) then
  342.       dos_exists := false
  343.    else
  344.       dos_exists := true;
  345. end;
  346.  
  347. procedure allstatus;
  348.  
  349. var vot:integer;
  350. var lev:real;
  351. begin
  352.  
  353.  clearscr;
  354.  movexy (1,8);
  355.    writeln (^R'                    ╔═════════════════════════════════════╗');
  356.    writeln (^R'                    ║        '^P'   User Main Level'^R'           ║');
  357.    writeln (^R'                    ║ '^P'Name'^R'          :                     ║');
  358.    writeln (^R'                    ║ '^P'Note'^R'          :                     ║');
  359.    writeln (^R'                    ║ '^P'Level'^R'         :                     ║');
  360.    writeln (^R'                    ║ '^P'Password'^R'      :                     ║');
  361.    writeln (^R'                    ║ '^P'Phone'^R'         :                     ║');
  362.    writeln (^R'                    ║ '^P'Time on'^R'       :                     ║');
  363.    writeln (^R'                    ║ '^P'Time Left'^R'     :                     ║');
  364.    writeln (^R'                    ║ '^P'Voting Record'^R' :                     ║');
  365.    writeln (^R'                    ║ '^P'Wanted Status'^R' :                     ║');
  366.      if useqr then begin
  367.       calcqr;
  368.    writeln (^R'                    ║ '^P'Quality Rating'^R':                     ║');
  369.   end;
  370.    writeln (^R'                    ╚═════════════════════════════════════╝');
  371.   printxy (39,11,urec.handle);
  372.   printxy (39,12,urec.note);
  373.   printxy (39,13,strr(urec.level));
  374.   printxy (39,14,urec.password);
  375.   printxy (39,15,urec.phonenum);
  376.   printxy (39,16,streal(urec.totaltime));
  377.   printxy (39,17,strr(urec.timetoday));
  378.   movexy (1,17);
  379.    write (^R'                    ║ '^P'Voting Record'^R' : ');
  380.    for vot:=1 to maxtopics do begin          { x,y = 38,18 }
  381.       if vot<>1 then write (',');
  382.      write (^S,urec.voted[vot]);
  383.    end;
  384.   printxy (39,19,yesno(wanted in urec.config)+^R);
  385.   if useqr then begin
  386.      calcqr;
  387.    printxy (39,20,strr(qr));
  388.   end;
  389.   printxy (1,1,^R+'╔══════════════════════════════════════════════════════════════════════════════╗');
  390.   printxy (1,2,^R+'║                            '^P'File Transfer Section'^R'                             ║');
  391.   printxy (1,3,^R+'║ '^P'Transfer Level '^R':                         '^P'Uploaded K  '^R':                       ║');
  392.   printxy (1,4,^R+'║ '^P'Transfer Points'^R':                         '^P'Downloaded K'^R':                       ║');
  393.   printxy (1,5,^R+'║ '^P'Uploads        '^R':                         '^P'File K Ratio'^R':                       ║');
  394.   printxy (1,6,^R+'║ '^P'Downloads      '^R':                         '^P'U/D Ratio   '^R':                       ║');
  395.   printxy (1,7,^R+'╚══════════════════════════════════════════════════════════════════════════════╝');
  396.   printxy (20,3,strr(urec.udlevel));
  397.   printxy (20,4,strr(urec.udpoints));
  398.   printxy (20,5,strr(urec.uploads));
  399.   printxy (20,6,strr(urec.downloads));
  400.   printxy (58,3,streal(urec.upk/1000));
  401.   printxy (58,4,streal(urec.downk/1000));
  402.   printxy (58,5,streal(ratio(urec.upk,urec.downk))+'%');
  403.   printxy (58,6,strr(percent(urec.uploads,urec.downloads))+'%');
  404.   printxy (1,09,^R'┌──────────────────┐');
  405.   printxy (1,10,^R'│ '^P'Level '^R'   :       │');
  406.   printxy (1,11,^R'│ '^P'Uploads  '^R':       │');
  407.   printxy (1,12,^R'│ '^P'Downloads'^R':       │');
  408.   printxy (1,13,^R'│ '^P'Ratio '^R'   :       │');
  409.   printxy (1,14,^R'└──────────────────┘');
  410.   printxy (14,10,strr(urec.gflevel));
  411.   printxy (14,11,strr(urec.gfuploads));
  412.   printxy (14,12,strr(urec.gfdownloads));
  413.   printxy (14,13,strr(percent(urec.gfuploads,urec.gfdownloads))+'%');
  414.   printxy (60,09,^R'┌───────────────────┐');
  415.   printxy (60,10,^R'│ '^P'Posts'^R'    :        │');
  416.   printxy (60,11,^R'│ '^P'Calls'^R'    :        │');
  417.   printxy (60,12,^R'│ '^P'PCR  '^R'    :        │');
  418.   printxy (60,13,^R'│ '^P'Last Date'^R':        │');
  419.   printxy (60,14,^R'│ '^P'Last Time'^R':        │');
  420.   printxy (60,15,^R'└───────────────────┘');
  421.   printxy (73,10,strr(urec.nbu));
  422.   printxy (73,11,strr(urec.numon));
  423.   printxy (73,12,strr(percent(urec.nbu,urec.numon))+'%');
  424.   if laston<>0 then printxy (73,13,datestr(urec.laston)) else
  425.          printxy (73,13,'None.');
  426.   if laston<>0 then printxy (73,14,timestr(urec.laston)) else
  427.          printxy (73,14,'None.');
  428.   movexy (1,20);
  429.    end;
  430.  
  431. procedure discon;
  432. begin
  433.        unum:=-1;
  434.        disconnect;
  435. end;
  436.    function dos_maxavail: longint;
  437.    var
  438.       reg:     registers;
  439.    begin
  440.       reg.ah := $48;
  441.       reg.bx := $FFFF;
  442.       msdos(reg);
  443.       dos_maxavail := longint(reg.bx) shl 4;
  444.    end;
  445.  
  446.    procedure dos_getmem(var ptrvar; size: word);
  447.    var
  448.       block:   pointer_rec absolute ptrvar;
  449.       reg:     registers;
  450.    begin
  451.       reg.ah := $48;
  452.       reg.bx := (size+15) div 16;
  453.       msdos(reg);
  454.  
  455.       if (reg.flags and Fcarry) <> 0 then
  456.       begin
  457.          writeln('dos_getmem: can''t allocate ',size,' bytes.');
  458.          halt(99);
  459.       end;
  460.  
  461.       block.segment := reg.ax;
  462.       block.offset := 0;
  463.    end;
  464.  
  465.    procedure dos_freemem(var ptrvar);
  466.    var
  467.       block:   pointer_rec absolute ptrvar;
  468.       reg:     registers;
  469.    begin
  470.       if (block.segment = 0) and (block.offset = 0) then
  471.          exit;
  472.  
  473.       reg.ah := $49;
  474.       reg.es := block.segment;
  475.       msdos(reg);
  476.  
  477.       if (reg.flags and Fcarry) <> 0 then
  478.       begin
  479.          writeln('dos_freemem: dispose failure');
  480.          halt(99);
  481.       end;
  482.  
  483.       block.segment := 0;
  484.       block.offset := 0;
  485.    end;
  486.  
  487. end.
  488.