home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ECO30603.ZIP / ECO30603.LZH / ECOLIBCS / ECO_LIBP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-03-01  |  222.0 KB  |  7,871 lines
  1. {$A-,B-,D-,E-,F+,I-,L-,N-,O-,R-,S-,V-}
  2. {$M 65520, 0, 655360}
  3.  
  4. {$DEFINE USETURBODOS}
  5. {$DEFINE USETURBOCRT}
  6.  
  7. unit eco_libp;
  8. interface
  9. uses
  10.   crt
  11.  
  12. {$IFDEF USETURBODOS}
  13.   , dos
  14. {$ENDIF}
  15.  
  16.   ;
  17.  
  18.  
  19.  
  20.  
  21. {$IFNDEF VER40}
  22.   {$IFNDEF VER50}
  23.     {$IFNDEF VER55}
  24.       {$IFNDEF VER70}
  25.         {$IFNDEF VER10}
  26.           {$DEFINE VER3HEAP}
  27.         {$ENDIF}
  28.       {$ENDIF}
  29.     {$ENDIF}
  30.   {$ENDIF}
  31. {$ENDIF}
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38. const
  39.   _dosminorver = 0; _dosmajorver = 5;
  40.   none = $00; only = $40; notnone = $80;
  41.  
  42.   _period      = $342E;  _colon       = $273A;  _c_2= $0300;
  43.   _slash       = $352F;  _padslash    = $E02F;  _c_6= $071E;
  44.                                                 _c_minus = $0C1F;
  45.   _left        = $4BE0;  _padleft     = $4B00;
  46.   _cleft       = $73E0;  _cpadleft    = $7300;
  47.   _right       = $4DE0;  _padright    = $4D00;
  48.   _cright      = $74E0;  _cpadright   = $7400;
  49.   _up          = $48E0;  _padup       = $4800;
  50.   _down        = $50E0;  _paddown     = $5000;
  51.   _pgup        = $49E0;  _padpgup     = $4900;
  52.   _pgdn        = $51E0;  _padpgdn     = $5100;
  53.   _home        = $47E0;  _padhome     = $4700;
  54.   _chome       = $7700;  _end         = $4FE0;
  55.   _padend      = $4F00;  _cend        = $7500;
  56.   _ins         = $52E0;  _padins      = $5200;
  57.   _del         = $53E0;  _paddel      = $5300;
  58.   _spaddel     = $532E;  _backspace   = $0E08;
  59.   _minus       = $0C2D;  _padminus    = $4A2D;
  60.   _plus        = $0D2B;  _padplus     = $4E2B;
  61.   _star        = $092A;  _padstar     = $372A;
  62.   _enter       = $1C0D;  _newline     = $1C0A;
  63.   _padenter    = $E00D;
  64.  
  65.   _tab         = $0F09;  _s_tab       = $0F00;
  66.   _esc         = $011B;  _space       = $3920;
  67.  
  68.   _a    = $1E61;  _b     = $3062;  _s_a  = $1E41;  _s_b   = $3042;
  69.   _c    = $2E63;  _d     = $2064;  _s_c  = $2E43;  _s_d   = $2044;
  70.   _e    = $1265;  _f     = $2166;  _s_e  = $1245;  _s_f   = $2146;
  71.   _g    = $2267;  _h     = $2368;  _s_g  = $2247;  _s_h   = $2348;
  72.   _i    = $1769;  _j     = $246A;  _s_i  = $1749;  _s_j   = $244A;
  73.   _k    = $256B;  _l     = $266C;  _s_k  = $254B;  _s_l   = $264C;
  74.   _m    = $326D;  _n     = $316E;  _s_m  = $324D;  _s_n   = $314E;
  75.   _o    = $186F;  _p     = $1970;  _s_o  = $184F;  _s_p   = $1950;
  76.   _q    = $1071;  _r     = $1372;  _s_q  = $1051;  _s_r   = $1352;
  77.   _s    = $1F73;  _t     = $1474;  _s_s  = $1F53;  _s_t   = $1454;
  78.   _u    = $1675;  _v     = $2F76;  _s_u  = $1655;  _s_v   = $2F56;
  79.   _w    = $1177;  _x     = $2D78;  _s_w  = $1157;  _s_x   = $2D58;
  80.   _y    = $1579;  _z     = $2C7A;  _s_y  = $1559;  _s_z   = $2C5A;
  81.  
  82.   _c_a  = $1E01;  _c_b   = $3002;  _a_a  = $1E00;  _a_b   = $3000;
  83.   _c_c  = $2E03;  _c_d   = $2004;  _a_c  = $2E00;  _a_d   = $2000;
  84.   _c_e  = $1205;  _c_f   = $2106;  _a_e  = $1200;  _a_f   = $2100;
  85.   _c_g  = $2207;  _c_h   = $2308;  _a_g  = $2200;  _a_h   = $2300;
  86.   _c_i  = $1709;  _c_j   = $240A;  _a_i  = $1700;  _a_j   = $2400;
  87.   _c_k  = $250B;  _c_l   = $260C;  _a_k  = $2500;  _a_l   = $2600;
  88.   _c_m  = $320D;  _c_n   = $310E;  _a_m  = $3200;  _a_n   = $3100;
  89.   _c_o  = $180F;  _c_p   = $1910;  _a_o  = $1800;  _a_p   = $1900;
  90.   _c_q  = $1011;  _c_r   = $1312;  _a_q  = $1000;  _a_r   = $1300;
  91.   _c_s  = $1F13;  _c_t   = $1414;  _a_s  = $1F00;  _a_t   = $1400;
  92.   _c_u  = $1615;  _c_v   = $2F16;  _a_u  = $1600;  _a_v   = $2F00;
  93.   _c_w  = $1117;  _c_x   = $2D18;  _a_w  = $1100;  _a_x   = $2D00;
  94.   _c_y  = $1519;  _c_z   = $2C1A;  _a_y  = $1500;  _a_z   = $2C00;
  95.  
  96.   _f1   = $3B00;  _f2    = $3C00;  _f3   = $3D00;  _f4    = $3E00;
  97.   _f5   = $3F00;  _f6    = $4000;  _f7   = $4100;  _f8    = $4200;
  98.   _f9   = $4300;  _f10   = $4400;
  99.  
  100.   _s_f1 = $5400;  _s_f2  = $5500;  _s_f3 = $5600;  _s_f4  = $5700;
  101.   _s_f5 = $5800;  _s_f6  = $5900;  _s_f7 = $5A00;  _s_f8  = $5B00;
  102.   _s_f9 = $5C00;  _s_f10 = $5D00;
  103.  
  104.   _c_f1 = $5E00;  _c_f2  = $5F00;  _c_f3 = $6000;  _c_f4  = $6100;
  105.   _c_f5 = $6200;  _c_f6  = $6300;  _c_f7 = $6400;  _c_f8  = $6500;
  106.   _c_f9 = $6600;  _c_f10 = $6700;
  107.  
  108.   _a_f1 = $6800;  _a_f2  = $6900;  _a_f3 = $6A00;  _a_f4  = $6B00;
  109.   _a_f5 = $6C00;  _a_f6  = $6D00;  _a_f7 = $6E00;  _a_f8  = $6F00;
  110.   _a_f9 = $7000;  _a_f10 = $7100;
  111.  
  112.   _left_just_str       = 0;
  113.   _right_just_str      = 1;
  114.   _center_str          = 2;
  115.  
  116.   _rem_white_str       = $0001;
  117.   _rem_lead_white_str  = $0002;
  118.   _rem_trail_white_str = $0004;
  119.   _reduce_white_str    = $0008;
  120.   _save_quoted_str     = $0010;
  121.   _to_upcase_str       = $0020;
  122.   _to_lowcase_str      = $0040;
  123.   _discard_str         = $0080;
  124.  
  125.   _usa_dt_str          = 0;
  126.   _euro_dt_str         = 1;
  127.   _year_dt_str         = 2;
  128.   _mont_dt_str         = 3;
  129.   _form_dt_str         = 4;
  130.  
  131.   _12hour_str          = $0001;
  132.   _inc_sec_str         = $0002;
  133.   _inc_tic_str         = $0004;
  134.   _inc_ampm_str        = $0008;
  135.   _standard_str        = $0009;
  136.   _complete_str        = $0006;
  137.   _dos_dir_str         = $0011;
  138.  
  139.   _ampm_str            : array[0..1] of string[3] = (' AM',' PM');
  140.   _ap_str              : string[2] = 'ap';
  141.  
  142.   _fmt_buflen_str      = 256;
  143.  
  144.   _strmonths  : array[1..12] of string[9] = (
  145.     'January', 'February', 'March', 'April', 'May', 'June', 'July',
  146.     'August', 'September', 'October', 'November',  'December'
  147.   );
  148.  
  149.   _strdays    : array[0..6] of string[9] = (
  150.     'Sunday', 'Monday', 'Tuesday', 'Wednesday',
  151.     'Thursday', 'Friday', 'Saturday'
  152.   );
  153.   _colours    : array[0..15] of string[12] = (
  154.     'Black', 'Blue', 'Green', 'Cyan', 'Red', 'Magenta', 'Brown',
  155.     'LightGray', 'Darkgray', 'LightBlue', 'LightGreen', 'LightCyan',
  156.     'LightRed', 'LightMagenta', 'Yellow', 'White'
  157.   );
  158.  
  159.   _strusach   : char = '/';
  160.   _streuroch  : char = '-';
  161.   _strmoneych : char = 'f';
  162.  
  163.   _dirslash   : char = '/';
  164.   _dircase    : word = _to_lowcase_str;
  165.  
  166.   fk_ctrl_mark: char = '^';
  167.   nonblock    : char = '-';
  168.   block       : char = 'X';
  169.   maxstr_     =        255;
  170.  
  171. {$IFNDEF USETURBODOS}
  172.  
  173.   (* flags bit masks *)
  174.  
  175.   fcarry     = $0001;
  176.   fparity    = $0004;
  177.   fauxiliary = $0010;
  178.   fzero      = $0040;
  179.   fsign      = $0080;
  180.   foverflow  = $0800;
  181.  
  182.   (* file mode magic numbers *)
  183.  
  184.   fmclosed = $d7b0;
  185.   fminput  = $d7b1;
  186.   fmoutput = $d7b2;
  187.   fminout  = $d7b3;
  188.  
  189.  
  190.   (* file attribute constants *)
  191.   readonly  = $01;
  192.   hidden    = $02;
  193.   sysfile   = $04;
  194.   volumeid  = $08;
  195.   directory = $10;
  196.   archive   = $20;
  197.   anyfile   = $3f;
  198. {$ENDIF}
  199.  
  200.  
  201. type
  202.   stream = file;
  203. {$IFNDEF USETURBOCRT}
  204.   textbuf = array [0..127] of char;
  205.   textrec = record
  206.     handle    : word;
  207.     mode      : word;
  208.     bufsize   : word;
  209.     private   : word;
  210.     bufpos    : word;
  211.     bufend    : word;
  212.     bufptr    : ^textbuf;
  213.     openfunc  : pointer;
  214.     inoutfunc : pointer;
  215.     flushfunc : pointer;
  216.     closefunc : pointer;
  217.     userdata  : array [1..16] of byte;
  218.     name      : array [0..79] of char;
  219.     buffer    : textbuf;
  220.   end;
  221. {$ENDIF}
  222.  
  223.   comstr  = string[127];        { command line string }
  224.   pathstr = string[79];         { full file path string }
  225.   dirstr  = string[67];         { drive and directory string }
  226.   namestr = string[8];          { file name string }
  227.   extstr  = string[4];          { file extension string }
  228.   filestr = string[12];         { file name + extension string }
  229.  
  230. {$IFNDEF USETURBODOS}
  231.   registers = record case integer of
  232.     0 : (ax,bx,cx,dx,bp,si,di,ds,es,flags : word);
  233.     1 : (al,ah,bl,bh,cl,ch,dl,dh : byte);
  234.   end;
  235.   searchrec = record
  236.     fill : array [1..21] of byte;
  237.     attr : byte;
  238.     time : longint;
  239.     size : longint;
  240.     name : string[12];
  241.   end;
  242.   datetime = record
  243.     year,month,day,hour,min,sec : word;
  244.   end;
  245. {$ENDIF}
  246.  
  247.   _memorychar = array[1..65534] of char;
  248.   _vectoraddr = record _ofs : word; _seg : word end;
  249.   str3        =              string[3];
  250.   str8        =              string[8];
  251.   str9        =              string[9];
  252.   str32       =             string[32];
  253.   anystr      =                 string;
  254.   asciiz      =  array[0..255] of char;
  255.   asciizptr   =                ^asciiz;
  256.   ar1024      = array[1..1024] of char;
  257.  
  258.  
  259.  
  260. const
  261.   nullchar = $00;
  262.   colon    = ':';
  263.   period   = '.';
  264.   separ    = '·';
  265.   space    = ' ';
  266.   zero     = '0';
  267.   maxtimer =  10;
  268.  
  269. type
  270.   daterecord = record
  271.     year      : word;
  272.     month     : word;
  273.     date      : word;
  274.     dayofweek : word
  275.   end;
  276.  
  277.   timerecord = record
  278.     hour      : word;
  279.     minute    : word;
  280.     second    : word;
  281.     hundredth : word
  282.   end;
  283.  
  284.   clockrecord = record
  285.     clockstartdate : daterecord;
  286.     clockstarttime : timerecord;
  287.     elapsedtime    : timerecord;
  288.     clockisrunning : boolean;
  289.   end;
  290.  
  291. var
  292.   clockarray     : array[0..maxtimer] of clockrecord;
  293.   exitcode       :    word;
  294. {$IFNDEF USETURBODOS}
  295.   doserror       : integer;
  296. {$ENDIF}
  297.   _dosdrv        : integer;
  298.   _dosdrvchar    :    char;
  299.   _doscurpath    : pathstr;
  300.   _dospath       :  string;
  301.   _dosdiscfree,
  302.   _dosdiscsize   : longint;
  303.  
  304.  
  305.  
  306.  
  307.  
  308.  
  309.  
  310.  
  311. { BASE STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  312.   function __leftstr(source : string;   num : word): string;
  313.   function __rightstr(source : string; chpos : word): string;
  314.   function __substr(source : string;   chpos, num: word): string;
  315.   function __midstr(source,target : string; chpos: word): string;
  316.   function __fillstr(
  317.     fillch : char; target : string;
  318.     chpos,num : word
  319.   ): string;
  320.   function __xlatestr(source,table,trans : string) : string;
  321.   function __juststr(
  322.     source : string;  fillch : char;
  323.     fieldsize : word;
  324.     justcode : word
  325.   ): string;
  326.   function __cvtstr(source : string; cvtcode : word) : string;
  327.   function __entabstr(source : string; incr : byte) : string;
  328.   function __detabstr(
  329.     source : string; incr : byte;
  330.     var remstr : string
  331.   ): string;
  332.   function __toradstr(
  333.     intvalue : longint;
  334.     size,radix,width: word
  335.   ): string;
  336.   function __todecstr(intvalue: longint; size: word) : string;
  337.   function __tohexstr(intvalue: longint; size: word) : string;
  338.   function __ptr2str(thisptr: pointer): string;
  339.   function __formstr(mask : string; x : real) : string;
  340.   procedure __initfstr(var fmtfil : text);
  341.   function __retbfstr(var fmtfil : text) : string;
  342.   function locase(ch: char): char;
  343.   function __part(s: string; a, b: byte): string;
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350.  
  351. { SECONDARY STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  352.   procedure __app(var st: string; aps: string);
  353.   function  __backapp(s: string) : string;
  354.   function  __backrem(s: string) : string;
  355.   function  __lastchr(s: string) : char;
  356.  
  357.   function  __comp(s1, s2: string): boolean;
  358.   function  __overtype(n:byte;strs,strt:string):string;
  359.   function  __rep(n: byte; character: char): string;
  360.   function  __nw(s: string): string;
  361.  
  362.   function  __pntstr(n: longint): string;
  363.   function  __up(s: string): string;
  364.   function  __lo(s: string): string;
  365.   function  __uprem(s: string): string;
  366.  
  367.   function  __hexdecstr(hexstr: string): longint;
  368.   function  __str(st: string): integer;
  369.   function  __num(nr: longint): string;
  370.   function  __val(st: string): longint;
  371.   function  __real(st: string): real;
  372.   function  __streal(nr: real; decs: byte): string;
  373.  
  374.   function  __byte2str(b: byte): str8;
  375.   function  __str2byte(s: str8): byte;
  376.   function  __longint2str(l: longint): str32;
  377.   function  __str2longint(s: str32): longint;
  378.  
  379.   procedure __str2obj(s: anystr; var a; length_a: integer);
  380.   procedure __str2arr(s: anystr; var a; length_a: integer);
  381.   function  __readctrls(s: anystr): anystr;
  382.   function  __writectrls(s: anystr): anystr;
  383.   function  __az2str(a: asciiz): string;
  384.   procedure __str2az(s: string; var a : asciiz);
  385.  
  386.   procedure __clr1024(var a: ar1024);
  387.   procedure __app1024(var app: ar1024; s: string);
  388.   function  __len1024(var a: ar1024) : word;
  389.   procedure __del1024(var a: ar1024; b, l: word);
  390.   procedure __ins1024(var a: ar1024; b : word; s: string);
  391.   procedure __write1024(var a: ar1024);
  392.  
  393.   function  __nonascii(s: string): boolean;
  394.   function  __killnonascii(s: string): string;
  395.  
  396.  
  397.  
  398.  
  399.  
  400. { PRIMARY DATA CONVERSION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  401.   function  __main(b: longint; w: word): longint;
  402.   function  __max(v1, v2: longint): longint;
  403.   function  __min(v1, v2: longint): longint;
  404.   function  __power(x,y: integer): longint;
  405.  
  406.  
  407.  
  408.   function __2longsup(hiword,loword : word): longint;
  409.   inline($58 { pop ax } /$5A); { pop dx          }
  410.  
  411.   function __hiwrdsup(intvalue : longint) : word;
  412.   inline($58 { pop ax } /$58); { pop ax }
  413.  
  414.     function __lowrdsup(intvalue : longint) : word;
  415.   inline($58 { pop ax } /$5A); { pop dx }
  416.  
  417.   function  __2wordsup(hibyte,lobyte : byte) : word;
  418.   inline($58 { pop ax } /$5A { pop dx } /$8A/$E2); { mov ah,dl }
  419.  
  420.   function __2bytesup(hinybble,lonybble : byte) : byte;
  421.   inline(
  422.     $5B/      { pop bx     }  $58/          { pop ax     }
  423.     $32/$E4/  { xor ah,ah  }  $b1/$04/      { mov cl,4   }
  424.     $d3/$E0/  { shl ax,cl  }  $80/$e3/$0f/  { and bl,0fh }
  425.     $0A/$C3   { or  al,bl  }
  426.   );
  427.  
  428.   function  __hinybsup(bytevalue : byte) : byte;
  429.   inline(
  430.     $58 { pop ax } /$32/$E4  { xor ah,ah }
  431.     /$B1/$04 { mov cl,4 } /$D3/$E8 { shr ax,cl }
  432.   );
  433.  
  434.     function __lonybsup(bytevalue : byte) : byte;
  435.   inline($58 { pop ax } /$25/$0F/$00); { and ax,000fh }
  436.   
  437.   procedure __fcallsup(procptr : pointer; var reg : registers);
  438.   inline(
  439.     $8B/$DC/ { mov  bx,sp } $83/$C3/$04/  { add  bx,4 }
  440.     $36/$FF/$1F/ { call dword ptr ss:[bx] } $83/$C4/$04 { add  sp,4 }
  441.   );
  442.  
  443.   procedure __ncallsup(procptr : pointer; var reg : registers);
  444.   inline(
  445.     $8B/$DC { mov  bx,sp } /$83/$C3/$04 { add  bx,4 }
  446.     /$36/$FF/$17 { call word ptr ss:[bx] } /$83/$C4/$04 { add  sp,4 }
  447.   );
  448.  
  449.     function  __caddrsup : pointer;
  450.     inline(
  451.     $8B/$46/$02 { mov ax,[bp + 2] } /$2D/$03/$00 { sub ax,3 }
  452.     /$8B/$56/$04 { mov dx,[bp + 4] }
  453.   );
  454.  
  455.   procedure __iptrsup (var p : pointer; n : longint);
  456.   procedure __dptrsup (var p : pointer; n : longint);
  457.   function  __nptrsup (thisptr : pointer) : pointer;
  458.   function  __ptr2lsup(thisptr : pointer) : longint;
  459.   procedure __fillwsup(var target; count : longint; fillword : word);
  460.   procedure __fillbsup(var target; count : longint; fillbyte : byte);
  461.   procedure __repmsup (var target,source; count : longint; sourcesize : word);
  462.   function  __alphasup(ch : char) : boolean;
  463.  
  464.  
  465.  
  466.  
  467.  
  468.  
  469. { IMPORTANT DOS FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  470. const
  471.   _keep_mode  = -1;        { do not change file mode in fopen }
  472.   _readonly   = $00;       {     share mode dos 3++ and above }
  473.   _denyall    = $10;
  474.   _writeonly  = $01;
  475.   _denywrite  = $20;
  476.   _readwrite  = $02;
  477.   _denyread   = $30;
  478.   _denynone   = $40;
  479.  
  480.   lockregion   = 00;
  481.   unlockregion = 01;
  482.  
  483.  
  484. {typed}const
  485.   casesensitive_env: boolean = false;
  486.  
  487. var
  488.   lastkey     :    char;
  489.   lastscan    :    byte;
  490.   _envseg     :    word;
  491.   envsize_    :    word;
  492.   envmemptr_,
  493.   _envptr,
  494.   envptr      : pointer; { pointer to environment table }
  495.   registeredprogname : string;
  496.  
  497.  
  498. {$IFNDEF USETURBODOS}
  499.   procedure getdate(var year,month,day,dayofweek : word);
  500.   procedure setdate(year,month,day : word);
  501.   procedure gettime(var hour,minute,second,sec100 : word);
  502.   procedure settime(hour,minute,second,sec100 : word);
  503.  
  504.   function  diskfree(drive : byte) : longint;
  505.   function  disksize(drive : byte) : longint;
  506.  
  507.   procedure getfattr(var f;var attr : word);
  508.   procedure setfattr(var f;attr : word);
  509.   procedure getftime(var f;var time : longint);
  510.   procedure setftime(var f;time : longint);
  511.  
  512.   procedure findfirst(path : pathstr;attr : word;var f : searchrec);
  513.   procedure findnext(var f : searchrec);
  514.  
  515.   function  fexpand(path : pathstr) : pathstr;
  516.   procedure fsplit(
  517.     path : pathstr;var dir : dirstr;
  518.     var name : namestr;var ext : extstr
  519.   );
  520.   procedure intr(intno: byte; var regs: registers);
  521.   procedure getintvec(intno: byte;var vector: pointer);
  522.   procedure swapvectors;
  523. {$ENDIF}
  524.  
  525.   function  __existfil(pathname : string) : boolean;
  526.   procedure __erasefil(filename : pathstr; var errorcode : word);
  527.   function  __progname: string;
  528.  
  529.  
  530. type
  531.   _keystatus = record          { keyboard shift status record }
  532.     _rightctrlshift: boolean;  {      right ctrl depressed    }
  533.     _rightaltshift : boolean;  {      right alt  depressed    }
  534.     _insstate      : boolean;  {      insert state is active  }
  535.     _capsstate     : boolean;  {      caps lock key toggled   }
  536.     _numstate      : boolean;  {      num lock key toggled    }
  537.     _scrollstate   : boolean;  {      scroll lock key toggled }
  538.     _altshift      : boolean;  {      alt shift key depressed }
  539.     _ctrlshift     : boolean;  {      ctrl shift depressed    }
  540.     _leftshift     : boolean;  {      left shift key depressed}
  541.     _rightshift    : boolean;  {      right shift depressed   }
  542.     _insshift      : boolean;  {      ins key depressed       }
  543.     _capsshift     : boolean;  {      caps lock key depressed }
  544.     _numshift      : boolean;  {      num lock key depressed  }
  545.     _scrollshift   : boolean;  {      scroll lock depressed   }
  546.     _holdstate     : boolean;  {      suspend state toggled   }
  547.     _sysshift      : boolean;  {      sysreq depressed & held }
  548.     _leftctrlshift : boolean;  {      left ctrl depressed     }
  549.     _leftaltshift  : boolean;  {      left alt depressed      }
  550.   end;
  551.  
  552.  
  553.   function  __dosinkey(var extendedcode : byte) : char;
  554.   function  __retkey: word;
  555.   function  __retdelaykey(delaytim: byte; default: word): word;  { delay < 60 }
  556.   function  __exinkey(useextended: boolean; var scancode: byte): char;
  557.   function  __exrdykey(
  558.     useextended : boolean;
  559.     var nextch : char;
  560.     var scancode : byte
  561.   ) : boolean;
  562.   function  keypressed : boolean;
  563.   procedure __flushkey;
  564.   function  __queuekey : word;
  565.   procedure __delay(w: word);
  566.   procedure __delaykey(w:word);
  567.   function __spaceutl(
  568.     drive : byte;
  569.     var availclus, totalclus,
  570.     bytespersec, secsperclus: word
  571.   ): longint;
  572.   function __paridutl(var cmdprocid : word) : word;
  573.   function cmdenvseg(var cmdprocid: word): word;
  574.   function __putenutl(envstr: string): string;
  575.   function __retenutl(var envpos : word) : string;
  576.   function __chgenutl(progseg: word; envstr: string; var error: word): string;
  577.   function __envpath(st: string): string; { ends on \ }
  578.   function __getpath(var fname : string) : boolean;
  579.  
  580.   function __address(zone, net, node, point: integer): string;
  581.   procedure __expandnum(
  582.     node : string; var tozone, tonet, tonode, topoint: word
  583.   );
  584.   function __expandchr(st: string; c: char; chh:  string): string;
  585.   function __statkey(var status : _keystatus) : longint;
  586.   function __ctrlkey(status : _keystatus) : longint;
  587.   function  __stuffkey(charstr : string) : string;
  588.   procedure __resetsup(testmem : boolean);
  589.   procedure __resetfil;
  590.  
  591.  
  592.  
  593.  
  594.  
  595.  
  596.  
  597.  
  598.  
  599.   { LOCK FUNCTIONS }
  600.   function fopen(var fv : stream; fn : pathstr; mode : integer) : integer;
  601.   function fclose(var fv : stream) : integer;
  602.   function shareloaded : boolean;
  603.   function filelock(
  604.     handle :    word;
  605.     action :    byte;
  606.     start,    
  607.     bytes  : longint;
  608.     var ax : integer
  609.   ): boolean;
  610.  
  611.  
  612.  
  613.  
  614.  
  615. { DATE FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  616.   function  __dt2ststr(year, month, day, datefmt : word): string;
  617.   function  __datestr(var year,month,day: word): string;
  618.   function  __timestr(var hours,minutes,seconds,tics: word): string;
  619.   procedure __st2dtstr(st: string; var year, month, day: word; datefmt: word);
  620.   function  __time2str(hours, mins, secs, tics, format: word): string;
  621.   function  __2timestr(timestr: string; var hours,mins,secs,tics:word): boolean;
  622.  
  623.   function  __retdowstr(dayofweek: word; ful: boolean): string;
  624.   function  __todaystr(ful: boolean): string;
  625.   procedure __jl2dtutl(julian: longint; var year, month, day, weekday: word);
  626.   function  __dt2jlutl(year, month, day : word) : longint;
  627.   function  __daysutl(yr1, mn1, day1 : word; yr2, mn2, day2 : word) : longint;
  628.   function  __retdow(y, m, d: word): word;
  629.   function  __today: byte;
  630.  
  631.   function  __curdate: string;
  632.   function  __curdate2longint: longint;
  633.   function  __longint2date(l: longint): string;
  634.   function  __date2longint(d: string): longint; {     'xx NNN yy  HH:MM.ss' }
  635.                                                 { eg. '22 Aug 69  14:50.11' }
  636.   procedure __longint2datetime(d : longint; var dt : datetime);
  637.   function  format_date(dt : datetime; format : byte): string;
  638.   function  __formatdate(d : longint; format : byte): string;
  639.  
  640.   function  __dbdate: string;
  641.   function  __radate: string;
  642.  
  643. {$IFNDEF USETURBODOS}
  644.   procedure unpacktime(p : longint;var t : datetime);
  645.   procedure packtime(var t : datetime;var p : longint);
  646. {$ENDIF}
  647.  
  648.  
  649.  
  650.  
  651.  
  652. { IMPORTANT TIMER FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  653.   procedure starttimer(whichclock : byte);
  654.   function  getlaptime(whichclock : byte) : string;
  655.   procedure restarttimer(whichclock : byte);
  656.   function  stoptimer(whichclock : byte) : string;
  657.  
  658.  
  659.  
  660.  
  661.  
  662.  
  663. { IMPORTANT FILE FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  664. const
  665.   info : array[0..6] of string[27] = (
  666.     'Successful.',
  667.     'Source and target the same!',
  668.     'Cannot open source!',
  669.     'Unable to create target!',
  670.     'Error during copy!',
  671.     'Cannot allocate buffer!',
  672.     'Not enough free discspace!'
  673.   );
  674.   function  __retdrfil : char;
  675.   function  __attrfilter(fileattr, filter: byte): boolean;
  676.   function  __bak(s: string): string;
  677.   function  __comexebatcmdfilter(s: string): boolean;
  678.   function  __curdir: string;
  679.   function  __deverr: string;
  680.   procedure __drvparm(drv: char);
  681.   procedure __erasefiles(s: string);
  682.   function  __existpath(s: string): boolean;
  683.   function  __extractext(name: string): str3;
  684.   function  __extractname(s : string): string;
  685.   function  __extractnamext(s : string): string;
  686.   function  __extractpath(s : string): string;
  687.   function  __findfil(f: string; var s: string): boolean;
  688.   function  __inparams(s: string; var i: word): boolean;
  689.   function  __checkstr(pa, en: string; var j, k : word): boolean;
  690.   function  __packfil(str: string; size: byte): string;
  691.   procedure __parsefil(name: filestr; var nam: namestr; var ext: extstr);
  692.   function  __slashfil(s: string): string;
  693.   function  __normfil(filename : pathstr) : pathstr;
  694.   procedure __splitfil(
  695.     pathname     :  pathstr;
  696.     var subdir   :   dirstr;
  697.     var filename :  namestr;
  698.     var fileext  :   extstr
  699.   );
  700.   function  __searchrec(
  701.     src                  : searchrec;
  702.     nm, woord, mainsize  :      word;
  703.     takemainsize, extended,
  704.     ampm, show_attr,
  705.     wide                 :   boolean
  706.   ): string;
  707.   function  __sizefil(pt: string): longint;
  708.   function  __strattr(attr: byte; full: boolean): string;
  709.   procedure __uniquefil(               { i.s.o. __tempfil, an unique textfile }
  710.     var pathname: string; var tmpfile: text; var errorcode: word
  711.   );
  712.   function  __copyfil(show: boolean; x1,x2,y,f,b: byte; fs: longint; src, targ: string): byte;
  713.   procedure __renamfil(prevname,newname : pathstr; var errorcode : word);
  714.   function  __slicefil(x1, x2, y, f, b: byte; haksize:longint; src:string): byte;
  715.   function  __isdrvfil(drive : char; var errorcode : word) : boolean;
  716.   function  __retvlfil(drive : char; var volstamp : longint) : string;
  717.   function  __handlfil(var filevar) : word;
  718.   function  __isconfil(handle : word) : boolean;
  719.  
  720.  
  721.  
  722.  
  723.  
  724.  
  725.  
  726.  
  727.  
  728.  
  729.  
  730.  
  731. const
  732.   maxfiles = 4096;
  733.  
  734. type
  735.   filarraytype = array[1..maxfiles] of ^searchrec;
  736.   filarraytypeptr = ^filarraytype;
  737.   sortmethods = (on_name, on_extension, on_datetime, on_size);
  738.   condition_attrstype = record
  739.     show_r_o : boolean;
  740.     show_hid : boolean;
  741.     show_sys : boolean;
  742.     show_arc : boolean;
  743.     show_vol : boolean;
  744.     show_dir : boolean;
  745.     show_non : boolean;
  746.     sort_method : sortmethods;
  747.   end;
  748.  
  749. const
  750.   std_condition_attrs : condition_attrstype = (
  751.     show_r_o    :  true;
  752.     show_hid    :  true;
  753.     show_sys    :  true;
  754.     show_arc    :  true;
  755.     show_vol    :  true;
  756.     show_dir    :  true;
  757.     show_non    :  true;
  758.     sort_method :  on_name
  759.   );
  760.  
  761.  
  762. var
  763.   conditionfuncptr_ : pointer;
  764.   filitems          :    word;
  765.  
  766.   {$F+}
  767.  
  768. const
  769.   renew_space : boolean = true;
  770.  
  771.   procedure set_std_condition_attrs(attrs: condition_attrstype);
  772.   procedure __dirutl(
  773.     comexebatcmdfilter  :         boolean;
  774.     searchpath          :         pathstr;
  775.     var filar           : filarraytypeptr;
  776.     searchattr          :            byte;
  777.     manipulate          :            byte;
  778.     var error,
  779.     counted_dirs        :            word;
  780.     vol_counted         :         boolean;
  781.     condit,
  782.     sorter              :         pointer;
  783.     var totnum          :         longint
  784.   );
  785.   procedure dispose_filarray(var fil: filarraytypeptr);
  786.   procedure new_filarray(var fil: filarraytypeptr);
  787.   function std_sort(var data1, data2): boolean;
  788.   function std_condition(var srec): boolean;
  789.   function no_condition(var srec): boolean;
  790.  
  791.  
  792.  
  793.  
  794.  
  795. { XXXXXXXXXX LOG FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  796. const                                                
  797.   logfilename : pathstr    = 'ECOPURGE.LOG';         { 22 Aug 69  14:50.11 }
  798.   programname : string[40] =     'ECOPURGE';
  799.   purge : byte =   7;
  800.   lines : word = 512;
  801.  
  802. var
  803.   logheader   : array[1..11] of string[62];
  804.   error,
  805.   yr, mo, da : word;
  806.   i          : byte;
  807.  
  808.  
  809.  
  810.   procedure __loginit;
  811.   procedure __logapp(s: string);
  812.   procedure __filapp(fil, s : string);
  813.  
  814.   procedure __setpurge(b: byte);
  815.   procedure __logpurge;
  816.  
  817.   function  __recent(s: string): boolean;
  818.  
  819.  
  820.  
  821.  
  822.  
  823. { XXXXXXXXXXXX FAST SCREEN FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  824.  
  825. type
  826.   _scnpos = record _ch : char; _attr : byte end;
  827.   _scnimage    = array[1..4000] of _scnpos;
  828.   _scnimageptr = ^_scnimage;
  829.   str80 = string[80];
  830.   _monitortype = (
  831.     _nomonitor,
  832.     _monomonitor,      { monochrome monitor             }
  833.     _colormonitor,     { color monitor (composite also) }
  834.     _enhancedmonitor,  { ega rnhanced color monitor     }
  835.     _anmonomonitor,    { ps/2 analog monochrome monitor }
  836.     _ancolormonitor    { ps/2 analog color monitor      }
  837.   );
  838.  
  839.  
  840. const
  841.   fcol: byte = 7;
  842.   bcol: byte = 0;
  843.   bt_double    = 15;     bt_single    =  1;
  844.   sh_default   = 255;    sh_high      = 254;   sh_low      = 253;
  845.   black        = 00;     blue         = 01;
  846.   green        = 02;     cyan         = 03;
  847.   red          = 04;     magenta      = 05;
  848.   brown        = 06;     lightgray    = 07;
  849.   darkgray     = 08;     lightblue    = 09;
  850.   lightgreen   = 10;     lightcyan    = 11;
  851.   lightred     = 12;     lightmagenta = 13;
  852.   yellow       = 14;     white        = 15;
  853.   blink        = 128;
  854.  
  855.   _unknown     = $7f;
  856.   _absent      = 0;                 { no adapter installed           }
  857.   _mono        = 1;                 { monochrome type adapter        }
  858.   _color       = 2;                 { color type adapter             }
  859.  
  860.   _biosseg     = $0040;             { segment of bios/dos communica- }
  861.  
  862.  
  863. var
  864.   _hidemouse      : byte;
  865.   baseofscreen,
  866.   vseg, vofs,
  867.   rows, cols, 
  868.   _curcolumns,                       { number of screen columns       }
  869.   _currows        : word;            { number of screen rows          }
  870.  
  871.   _scnloc         : _scnimageptr;    { screen adapter memory location }
  872.   _curmonitor     : _monitortype;    { monitor attached to _curdevice }
  873.   _curmode        : byte;            { current video display mode     }
  874.   _curdevice      : byte;            { _mono or _color device         }
  875.   _maxdisplaypage : byte;            { maximum display page number    }
  876.   _curdisplaypage : byte;            { current video display page     }
  877.   _curactivepage  : byte;            { current video active page      }
  878.   _monoadapter    : byte;            { monochrome adapter             }
  879.   _coloradapter   : byte;            { color/graphics adapter         }
  880.   _egaadapter     : byte;            { ega adapter                    }
  881.   _hercadapter    : byte;            { hercules mono graphics card    }
  882.   _vgaadapter     : byte;            { ps/2 video graphics array      }
  883.   _mcgaadapter    : byte;            { ps/2 model 30 adapter          }
  884.   _scrolltab      : word;            { spaces to skip for tab scroll  }
  885.   _tabincr        : word;            { tab increment for _txbufscn    }
  886.   _bufindent      : word;            { left margin for _txbufscn      }
  887.  
  888.   {scnstate_         : scnstat_;    }  { bios video save information    }
  889.   {availcolormodes_  : videomodes_; }  { modes available on color device}
  890.   {availmonomodes_   : videomodes_; }  { modes available on mono device }
  891.   {availcolorrows_   : legalrows_;  }  { rows available on color device }
  892.   {availmonorows_    : legalrows_;  }  { rows available on mono device  }
  893.   {dualdisplay_      : boolean;     }  { two adapters present           }
  894.   egamonitor_        : _monitortype;   { monitor attached: ega          }
  895.   analogmonitor_     : _monitortype;   { monitor attached: vga/mcga     }
  896.   egamemory_         : word;           { 64, 128, 192, or 256 (k)       }
  897.   maxscanline_       : byte;           { current character set size     }
  898.  
  899. var
  900.   scn1, scn2,
  901.   scn3, scn4         : _scnimageptr;
  902.  
  903.   function  at(f, b: byte): byte;
  904.   function  __loc(x, y : byte; var fore, back : byte): char;
  905.   procedure __scn(col, row, attr: byte; st: str80);
  906.   procedure __vid(col, row:       byte; st: str80);
  907.   procedure changeattr(col,row,attr: byte; number: word);
  908.   function  get_video_mode: byte;
  909.  
  910.   { extended functions, just like in eco_vid, but for small use }
  911.   procedure __attrib(x1, y1, x2, y2, f, b: byte);
  912.   procedure __bandwin(del: boolean; x1,y1,x2,y2,f,b,shadow,bt: byte);
  913.   procedure __betwscn(x1, x2, y, f, b: byte; st: string);
  914.   procedure __boxscn(x1,y1,x2,y2,boxtype,fore,back : byte);
  915.   procedure __clrscn(x1, y1, x2, y2, f, b: byte; c: char);
  916.   procedure __cls;
  917.   procedure __copyscn(x1, y1, x2, y2, x, y: byte);
  918.  
  919.   procedure __equipscn;
  920.   function __retdvscn(
  921.     var dvmode    : byte;
  922.     var dvcols    : word;
  923.     var dvrows    : word;
  924.     var dbactpage : byte;
  925.     var dvdispage : byte
  926.   ): byte;
  927.  
  928.   procedure __vert(x, y, f, b: byte; s: string);
  929.   procedure __write(col, row, f, b: byte; st: str80);
  930.   procedure __hwrite(x, y, f, b, h: byte; st: string);
  931.  
  932.   procedure __resscn(sc: _scnimageptr);
  933.   procedure __savscn(sc: _scnimageptr);
  934.   procedure __speedscn(
  935.     sourceptr,targetptr : pointer;
  936.         count,option,attribute : word;
  937.         wait : boolean
  938.   );
  939.   function  __barchoice(x,x1,y,f,b,h : byte; st: string; timeout: byte): byte;
  940.   { error = 255: debugging mode; else no debuginfo display }
  941.   function  __barcheck(s: string; var error: byte): boolean;
  942.   procedure __setblwin(blinkon : boolean);
  943.  
  944.  
  945.  
  946.  
  947.  
  948.  
  949. { XXXXXXXXXXXX CRT FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  950.   procedure __stdio;
  951.  
  952.  
  953.  
  954.  
  955.  
  956.  
  957.  
  958. { XXXXXXXXXXXX TEXT FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  959.  
  960. type
  961.   strptr = ^string;
  962.   textnodeptr = ^textnode;
  963.   textnode = record
  964.     next,prev :textnodeptr; {line may not be made longer}
  965.     line :strptr;   {allocation is length+1}
  966.   end;
  967.   textbuffer = record
  968.     first,last :textnodeptr;
  969.   end;
  970.  
  971.   {-
  972.     Note: Don't mess around inside the data structures defined above.
  973.     Use the procedures to access them instead.  This unit should be
  974.     written object orientated.  Some procedures don't use all their
  975.     parameters at the moment.  This is intentional and will be useful
  976.     if the structures are enhanced.
  977.   -}
  978.  
  979.   {- initialise an empty buffer -}
  980.   procedure newbuffer(var t :textbuffer);
  981.   
  982.   {- return true if the buffer is empty -}
  983.   function emptybuffer(var t :textbuffer) :boolean;
  984.   
  985.   {- return a pointer to the first line of a buffer -}
  986.   function firstline(var t :textbuffer) :textnodeptr;
  987.   
  988.   {- return a pointer to the last line of a buffer -}
  989.   function lastline(var t :textbuffer) :textnodeptr;
  990.   
  991.   {- return the next line in a buffer -}
  992.   function nextline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;
  993.   
  994.   {- return the previous line in a buffer -}
  995.   function prevline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;
  996.   
  997.   {- add a line to the end of a buffer -}
  998.   procedure addtoend(var t :textbuffer;  line :string);
  999.   
  1000.   {- insert a line before another line -}
  1001.   procedure addinsert(var t :textbuffer;  pos :textnodeptr;  line :string);
  1002.   
  1003.   {- delete a line and return the next line or nil if it was the last line -}
  1004.   function deleteline(var t :textbuffer;  var pos :textnodeptr) :textnodeptr;
  1005.   
  1006.   {- delete a buffer -}
  1007.   procedure deletebuffer(var t :textbuffer);
  1008.   
  1009.   {- retrieve the text value from a line -}
  1010.   function gettextline(var t: textbuffer;  pos :textnodeptr) :string;
  1011.   
  1012.   {- assign a new string to a line of text -}
  1013.   procedure modifytextline(var t: textbuffer;  pos :textnodeptr;  line :string);
  1014.   
  1015.   {- word wrap the buffer -}
  1016.   procedure wrapbuffer(var t :textbuffer;  margin :byte);
  1017.   
  1018.   {- create a new buffer with maximum length (255) lines -}
  1019.   procedure unwrapbuffer(var t,w :textbuffer);
  1020.   
  1021.   {- count the number of lines in a buffer -}
  1022.   function bufferlength(var t :textbuffer) :word;
  1023.   
  1024.   
  1025.   
  1026.   
  1027.   
  1028.   
  1029.   { XXXXXXXXXXXX CRC FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  1030.   function __crc32(value: byte; crc: longint) : longint;
  1031.   function __crc16(value: byte; crc: word)    :    word;
  1032.  
  1033.  
  1034.  
  1035.  
  1036.  
  1037.  
  1038.  
  1039.  
  1040.  
  1041.   { XXXXXXXXXXXX SELECTION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  1042.  
  1043. const
  1044.   _fore : byte =  7;
  1045.   _back : byte =  0;
  1046.   _x1   : byte = 10;
  1047.   _y1   : byte =  5;
  1048.   _x2   : byte = 30;
  1049.   _y2   : byte = 15;
  1050.  
  1051.   _noerror_sel     = 0;
  1052.   _nopickrec_sel   = 1;
  1053.   _invwindow_sel   = 2;
  1054.   _invpath_sel     = 3;
  1055.   _dispwin_sel     = 4;
  1056.   _titlewin_sel    = 5;
  1057.   _remwin_sel      = 6;
  1058.   _zapwin_sel      = 7;
  1059.   _memalloc_sel    = 8;
  1060.   _selerror : word = _noerror_sel;
  1061.   _nofilesmsg : string[10] = ' No Files';
  1062.   _name_fmt_sel    = 0;
  1063.   _dos_fmt_sel     = 1;
  1064.  
  1065.  
  1066. type
  1067.   _pickptr = ^_pick;
  1068.   _pick = record
  1069.     _barfore    :       byte;
  1070.     _barback    :       byte;
  1071.     _keyproc    :    pointer;
  1072.     _itemlen    :       word;
  1073.     _numitems   :       word;
  1074.     _itemsize   :       word;
  1075.     _numcols    :       word;
  1076.     _spacing    :       word;
  1077.     _itemaddr   :    pointer;
  1078.     _pointers   :    boolean;
  1079.     _firstpage  :       word;
  1080.     _lastpage   :       word;
  1081.     _curitemnum :       word;
  1082.     _curitemptr :    pointer;
  1083.   end;
  1084.  
  1085.  
  1086. var
  1087.   _initpickkey : word;
  1088.  
  1089.  
  1090.   function  __makesel(
  1091.     x1, y1,
  1092.     x2, y2,
  1093.     fore, back,
  1094.     barfore, 
  1095.     barback    :       byte;
  1096.     keyproc    :    pointer;
  1097.     itemlen    :       word;
  1098.     numitems   :       word;
  1099.     itemsize   :       word;
  1100.     numcols    :       word;
  1101.     spacing    :       word;
  1102.     itemaddr   :    pointer;
  1103.     ispointers :    boolean
  1104.   ) : _pickptr;
  1105.  
  1106.   function  __picksel(
  1107.     listpickptr : _pickptr;
  1108.     var retitem :   string;
  1109.     var retkey  :     word
  1110.   ) : word;
  1111.  
  1112.   procedure __itemsel(pickptr: _pickptr; fore, back: byte; itemno: word);
  1113.   function  __zapsel(var pickptr : _pickptr) : boolean;
  1114.  
  1115.  
  1116.  
  1117.  
  1118.  
  1119.  
  1120.  
  1121. { XXXXXXXXXXXX SELECTION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  1122. type
  1123.   _editctrl = record
  1124.     _viewx1,
  1125.     _viewx2,
  1126.     _viewy1,
  1127.     _vscnfore,
  1128.     _vscnback,
  1129.     _vscncols  :    word;
  1130.     _showflags : boolean;
  1131.     _mask      :  string; { ( * ) }
  1132.   end;
  1133.  
  1134.   { masks are currently not supported }
  1135.   {-------------------------------------------------------------}
  1136.   {                                                             }
  1137.   {  ( * ) masking                                              }
  1138.   {                                                             }
  1139.   {   Format Char    Input Allowed                              }
  1140.   {   -----------------------------------------------------     }
  1141.   {     &            (Any character)                            }
  1142.   {     #            0-9,+,-,.                                  }
  1143.   {     9            0-9                                        }
  1144.   {     X            0-9,+,-,.,A-Z,a-z,#32 (space)              }
  1145.   {     Y            (Same as X, convert to upper case)         }
  1146.   {     y            (Same as X, convert to lower case)         }
  1147.   {     A            A-Z,a-z,#32 (space)                        }
  1148.   {     B            (Same as A, convert to upper case)         }
  1149.   {     b            (Same as A, convert to lower case)         }
  1150.   {     ^            (Escape--treat next character as literal)  }
  1151.   {     *            same as &, but report * as user input (pwd)}
  1152.   {                                                             }
  1153.   {   Literal characters are displayed at the corresponding     }
  1154.   {   position within the data input field and are unaffected   }
  1155.   {   by operator input (the cursor skips over them).  A        }
  1156.   {   format character is treated as a literal character if it  }
  1157.   {   is preceded by a single escape character ('^').           }
  1158.   {                                                             }
  1159.   {   If a mask is specified, InitStr is validated against      }
  1160.   {   the mask, and if found invalid __editline exits with      }
  1161.   {   ErrorCode = 2.  Thereafter, the entire edit buffer        }
  1162.   {   is validated against the mask with each keypress.         }
  1163.   {   Invalid keystrokes cause the system speaker to sound and  }
  1164.   {   leave the edit buffer unchanged.  Inserting or            }
  1165.   {   deleting a character will be disallowed if it 'pushes'    }
  1166.   {   or 'pulls' a character into an invalid position relative  }
  1167.   {   to the mask.                                              }
  1168.   {                                                             }
  1169.   {   Examples of masks:                                        }
  1170.   {                                                             }
  1171.   {   '(999) 999-9999'     (telephone number)                   }
  1172.   {   '99/99/99'           (date)                               }
  1173.   {   '999-99-9999'        (social security number)             }
  1174.   {   'B-99999'            (part number, initial alpha char)    }
  1175.   {   '#########'          (real number)                        }
  1176.   {   'AAAAAAAAAAAAAAAAA'  (name field, alpha only)             }
  1177.   {                                                             }
  1178.   {   Case conversion specified by a mask takes precedence      }
  1179.   {   over case conversion specified with _EditMode.            }
  1180.   {                                                             }
  1181.   {   The editing viewport:  If the length of the field         }
  1182.   {   defined in _editctrl (_ViewX2 - _ViewX1 + 1) is less      }
  1183.   {   than the number of columns in the edit buffer             }
  1184.   {   (_VScnCols), editing may take place in a viewport which   }
  1185.   {   is shorter than the length of the edit buffer.  In such   }
  1186.   {   a case, moving the cursor to a position within the        }
  1187.   {   buffer which is not currently visible causes the          }
  1188.   {   buffer to scroll within the viewport.                     }
  1189.   {_____________________________________________________________}
  1190.   
  1191.  
  1192.   function __editline(var st: string; control: _editctrl): boolean;
  1193.  
  1194.  
  1195.  
  1196.  
  1197.  
  1198.  
  1199. { memory management }
  1200. const
  1201.   _max_getmem = 65520;
  1202.   _alloconfail : word = 0;
  1203.  
  1204. type
  1205.   _xads = record
  1206.     _loword : word;
  1207.     _hibyte : byte
  1208.   end;
  1209.  
  1210.   _progsize = record
  1211.     _codesize    : word;
  1212.     _datasize    : word;
  1213.     _stacksize   : word;
  1214.     _overlaysize : word;
  1215.     _heapsize    : word
  1216.   end;
  1217.  
  1218.   _memctrl = record
  1219.     _header   : char;
  1220.     _ownerpsp : word;
  1221.     _size     : word;
  1222.     _reserved : array[1..11] of byte
  1223.   end;
  1224.  
  1225.   _freerec = record
  1226.     _freeblockptr : pointer;
  1227.     _nextblockptr : pointer
  1228.   end;
  1229.  
  1230.   _freelist = array[0..8190] of _freerec;
  1231.  
  1232.  
  1233.  
  1234.   procedure __totalmem(var dosmemory, extmemory : word);
  1235.   procedure __availmem(
  1236.     var dosmemory, extmemory: word; var memptr: pointer; var extads: _xads
  1237.   );
  1238.   procedure __allocmem(
  1239.     blockreq: word; var memptr: pointer; var allocsize, errorcode: word
  1240.   );
  1241.   procedure __freemem (memptr: pointer; var errorcode: word);
  1242.   procedure __altermem(
  1243.     blockreq: word; memptr : pointer; var altersize, errorcode: word
  1244.   );
  1245.   function  __firstmem : pointer;
  1246.   function  __ctrlmem(memptr: pointer; var memblock: _memctrl): pointer;
  1247.   procedure __hookmem(progseg: word; var hookvecno: integer);
  1248.   procedure __xtmovmem(
  1249.     memptr: pointer; extads: _xads; nowords: word;
  1250.     toext: boolean; var errorcode: word
  1251.   );
  1252.   function  __fetchmem(p: pointer; itemsize: word; itemnum: longint): pointer;
  1253.  
  1254.  
  1255. type
  1256.   _3freerecptr = ^_3freerec;
  1257.   _3freerec    = record
  1258.     _nextfree  : _3freerecptr;
  1259.     _blocksize : pointer
  1260.   end;
  1261.  
  1262.  
  1263.   (*
  1264.     the following variables are used in conjunction with errorexit
  1265.     to provide an exit procedure for __hfreemem and __hgetmem.  this is
  1266.     needed so that a runtime error can be generated for invalid heap
  1267.     operations.  the turbo pascal 5.0 procedure runerror is not used as
  1268.     it is not avaiable for 4.0 and does not report the address of the
  1269.     statement that invokes __hfreemem or __hgetmem.
  1270.   *)
  1271.  
  1272. var
  1273.   prevexitproc_ : pointer;
  1274.   calleraddr_   : pointer;
  1275.  
  1276.  
  1277.  
  1278.  
  1279.  
  1280.  
  1281. { sort management }
  1282. const
  1283.   _default_srt  = $0000;             
  1284.   _insert_srt   = $0001;             
  1285.   _sortdata_srt = $0002;             
  1286.   _variable_srt = $0004;             
  1287.   _inmemory_srt = $0008;
  1288.   _leavemem_srt = $0010;
  1289.  
  1290.   _useinsertsrt : word    = 10;      
  1291.                                      
  1292.   _numsortedsrt : word    = 0;       
  1293.   _datasrt      : pointer = nil;     
  1294.   _datasizesrt  : longint = 0;       
  1295.   _ptrsrt       : pointer = nil;     
  1296.   _ptrsizesrt   : longint = 0;       
  1297.  
  1298.  
  1299.   procedure __isortsrt(
  1300.     dataptr : pointer;
  1301.     numrecords : word;
  1302.     recordsize : word;
  1303.     lessfunction : pointer
  1304.   );
  1305.   procedure __qsortsrt(
  1306.     dataptr : pointer;
  1307.     numrecords : word;
  1308.     recordsize : word;
  1309.     lessfunction : pointer
  1310.   );
  1311.  
  1312.   procedure __addsrt(
  1313.     dataptr : pointer;
  1314.     var errorcode : word
  1315.   );
  1316.  
  1317.   procedure __retsrt(
  1318.     var dataptr : pointer;
  1319.     var errorcode : word
  1320.   );
  1321.  
  1322.   procedure __sortsrt(
  1323.     maxrecords    :    word;
  1324.     recordsize    :    word;
  1325.     lessfunction  : pointer;
  1326.     inputproc     : pointer;
  1327.     outputproc    : pointer;
  1328.     sortcontrol   :    word;
  1329.     var errorcode :    word
  1330.   );
  1331.  
  1332.  
  1333.  
  1334.  
  1335.  
  1336.  
  1337.  
  1338.  
  1339.  
  1340.  
  1341.  
  1342.  
  1343.  
  1344.  
  1345. implementation
  1346.  
  1347.  
  1348.  
  1349.  
  1350.  
  1351.  
  1352.  
  1353.  
  1354.  
  1355.  
  1356.  
  1357.  
  1358.  
  1359.  
  1360.  
  1361.  
  1362.  
  1363.  
  1364. { BASE STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  1365.   function locase(ch: char): char;
  1366.   var j : word;
  1367.   begin
  1368.     if ch in ['A'..'Z'] then locase := chr(ord(ch) + 32) else locase := ch;
  1369.   end;
  1370.  
  1371.   
  1372.   
  1373.   function __part(s: string; a, b: byte): string;
  1374.   begin
  1375.     if b > length(s) then b := length(s);
  1376.     if b < a then a := b;
  1377.     __part := copy(s, a, b-a+1)
  1378.   end;
  1379.  
  1380.  
  1381.  
  1382.   function  __leftstr(source : string; num : word) : string;
  1383.   begin
  1384.     __leftstr := copy(source,1,num)
  1385.   end;
  1386.  
  1387.  
  1388.   function  __rightstr(source : string; chpos : word) : string;
  1389.   begin
  1390.     __rightstr := copy(source,chpos,maxstr_)
  1391.   end;
  1392.  
  1393.  
  1394.   function  __substr(source : string; chpos,num : word) : string;
  1395.   var startpos : word;
  1396.   begin
  1397.     if (chpos <= 0) then startpos := 1 else startpos := chpos;
  1398.     if (chpos <= length(source)) then
  1399.       __substr := copy(source,startpos,num) else __substr := ''
  1400.   end;
  1401.  
  1402.  
  1403.  
  1404.   function  __midstr(source, target : string; chpos : word) : string;
  1405.   var
  1406.     newtarget : string;
  1407.     newtarlen : byte;
  1408.     newlen    : word;
  1409.     newstrptr : ^_memorychar;
  1410.     lensource : word;
  1411.     lentarget : word;
  1412.  
  1413.   begin
  1414.     lensource := length(source);
  1415.     lentarget := length(target);
  1416.     newlen    := lensource + lentarget;
  1417.     getmem(newstrptr,newlen);
  1418.     if (newstrptr = nil) then begin __midstr := ''; exit end;
  1419.     if (chpos < 1) then chpos := 1 else if (chpos > lentarget) then
  1420.       chpos := lentarget + 1;
  1421.     move(target[1],newstrptr^[1],chpos - 1);
  1422.     move(source[1],newstrptr^[chpos],lensource);
  1423.     move(target[chpos],newstrptr^[chpos + lensource],
  1424.                                           lentarget - chpos + 1);
  1425.     if (newlen > maxstr_) then newtarget[0] := chr(maxstr_) else
  1426.       newtarget[0] := chr(newlen);
  1427.     move(newstrptr^,newtarget[1],length(newtarget));
  1428.     __midstr := newtarget;
  1429.     freemem(newstrptr,newlen)
  1430.   end;
  1431.  
  1432.  
  1433.  
  1434.   function __fillstr(
  1435.     fillch : char; target : string;
  1436.     chpos,num : word
  1437.   ) : string;
  1438.   var
  1439.     lentarget : word;
  1440.     startpos  : word;
  1441.  
  1442.   begin
  1443.     if (num <= 0) then exit;
  1444.     lentarget := length(target);
  1445.     if (chpos < 1) then startpos := 1 else if (chpos > lentarget) then
  1446.       startpos := lentarget + 1 else startpos := chpos;
  1447.     if (num > (maxstr_ - startpos + 1)) then num := maxstr_ - startpos + 1;
  1448.     fillchar(target[startpos],num,fillch);
  1449.     if (lentarget < (startpos + num)) then
  1450.       target[0] := chr(startpos + num - 1);
  1451.     __fillstr := target
  1452.   end;
  1453.  
  1454.  
  1455.  
  1456.   function  __xlatestr(source, table, trans : string) : string;
  1457.   const blank = #32;
  1458.   var
  1459.     i,j       : word;
  1460.     lensource : word;
  1461.     lentrans  : word;
  1462.     target    : string;
  1463.  
  1464.   begin
  1465.     lentrans  := length(trans);
  1466.     lensource := length(source);
  1467.     for i := 1 to lensource do begin
  1468.       j := pos(source[i],table);
  1469.       if (j > 0) then if (j > lentrans) then target[i] := blank else
  1470.         target[i] := trans[j] else target[i] := source[i]
  1471.     end;
  1472.     target[0]  := chr(lensource);
  1473.     __xlatestr      := target
  1474.   end;
  1475.  
  1476.  
  1477.  
  1478.   function  __juststr(
  1479.     source : string;
  1480.     fillch : char;
  1481.     fieldsize : word;
  1482.     justcode : word
  1483.   ) : string;
  1484.  
  1485.   var
  1486.     juststring : string;
  1487.     len        : word;
  1488.  
  1489.   begin
  1490.     if (fieldsize > maxstr_) then fieldsize  := maxstr_;
  1491.     fillchar(juststring[1],fieldsize,fillch);
  1492.     juststring[0] := chr(fieldsize);
  1493.     len           := length(source);
  1494.     case justcode of
  1495.       _right_just_str:
  1496.          if (len <= fieldsize) then
  1497.            move(source[1],juststring[fieldsize - len + 1],len) else
  1498.              move(source[len - fieldsize + 1],juststring[1],fieldsize);
  1499.       _center_str:
  1500.          if (len <= fieldsize) then
  1501.            move(source[1],juststring[((fieldsize - len) div 2) + 1],len) else
  1502.              move(
  1503.                source[((len - fieldsize) div 2) + 1],
  1504.                juststring[1],fieldsize
  1505.              );
  1506.       else begin
  1507.         if (len <= fieldsize) then move(source[1],juststring[1],len) else
  1508.           move(source[1],juststring[1],fieldsize)
  1509.       end;
  1510.     end;
  1511.     __juststr := juststring
  1512.   end;
  1513.  
  1514.  
  1515.  
  1516.   function  __cvtstr(source : string; cvtcode : word) : string;
  1517.   const
  1518.     blank    = #32;
  1519.     tab      = #9;
  1520.     quote    = #39;
  1521.     dquote   = #34;
  1522.     nul      = #0;
  1523.     linefeed = #10;
  1524.     vtab     = #11;
  1525.     formfeed = #12;
  1526.     creturn  = #13;
  1527.  
  1528.  
  1529.     function quotecheck(var lastquote : char; ch : char) : boolean;
  1530.     begin
  1531.       if ((ch = quote) or (ch = dquote)) then begin
  1532.         if (ch = lastquote) then begin
  1533.           quotecheck := false;
  1534.           lastquote  := blank
  1535.         end else if ((lastquote <> quote) and (lastquote <> dquote)) then begin
  1536.           quotecheck := true;
  1537.           lastquote  := ch
  1538.         end
  1539.       end else if ((lastquote = quote) or (lastquote = dquote)) then
  1540.         quotecheck := true else quotecheck := false
  1541.     end;
  1542.  
  1543.   var
  1544.     target    : string;
  1545.     isquote   : boolean;
  1546.     quoteon   : boolean;
  1547.     lastquote : char;
  1548.     deleteon  : boolean;
  1549.     i,j,len   : word;
  1550.     ch        : char;
  1551.  
  1552.   begin
  1553.     target    := source;
  1554.     isquote   := (cvtcode and 16) <> 0;
  1555.     quoteon   := false;
  1556.     lastquote := ' ';
  1557.     if ((cvtcode and _rem_white_str) <> 0) then begin
  1558.       len := length(source);
  1559.       i   := 1;
  1560.       j   := 0;
  1561.       while (i <= len) do begin
  1562.         ch := source[i];
  1563.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1564.         if (((ch <> blank) and (ch <> tab)) or quoteon) then begin
  1565.           inc(j);
  1566.           target[j] := ch
  1567.         end;
  1568.         inc(i);
  1569.       end;
  1570.       target[0] := chr(j)
  1571.     end;
  1572.  
  1573.     if ((cvtcode and _rem_lead_white_str) <> 0) then begin
  1574.       len := length(target);
  1575.       i   := 1;
  1576.       while (
  1577.         (i <= len) and ((target[i] = blank) or (target[i] = tab))
  1578.       ) do inc(i);
  1579.       delete(target,1,i - 1)
  1580.     end;
  1581.  
  1582.     if ((cvtcode and _rem_trail_white_str) <> 0) then begin
  1583.       len := length(target);
  1584.       i   := len;
  1585.       while (
  1586.         (i >= 1) and ((target[i] = blank) or (target[i] = tab))
  1587.       ) do dec(i);
  1588.       target := copy(target,1,i)
  1589.     end;
  1590.  
  1591.     if ((cvtcode and _reduce_white_str) <> 0) then begin
  1592.       deleteon  := false;
  1593.       lastquote := blank;
  1594.       len       := length(target);
  1595.       i         := 1;
  1596.       j         := 0;
  1597.       while (i <= len) do begin
  1598.         ch := target[i];
  1599.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1600.         if (((ch <> blank) and (ch <> tab)) or quoteon) then begin
  1601.           inc(j);
  1602.           target[j] := ch;
  1603.           deleteon  := false
  1604.         end else if (not deleteon) then begin
  1605.           inc(j);
  1606.           target[j] := blank;
  1607.           deleteon  := true
  1608.         end;
  1609.         inc(i)
  1610.       end;
  1611.       target[0] := chr(j)
  1612.     end;
  1613.  
  1614.     if ((cvtcode and _to_upcase_str) <> 0) then begin
  1615.       lastquote := blank;
  1616.       for i := 1 to length(target) do begin
  1617.         ch := target[i];
  1618.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1619.         if (not quoteon) then target[i] := upcase(ch)
  1620.       end
  1621.     end;
  1622.  
  1623.     if ((cvtcode and _to_lowcase_str) <> 0) then begin
  1624.       lastquote := blank;
  1625.       for i := 1 to length(target) do begin
  1626.         ch := target[i];
  1627.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1628.         if (not quoteon) then target[i] := locase(ch)
  1629.       end
  1630.     end;
  1631.  
  1632.     if ((cvtcode and _discard_str) <> 0) then begin
  1633.       lastquote := blank;
  1634.       len       := length(target);
  1635.       i         := 1;
  1636.       j         := 0;
  1637.       while (i <= len) do begin
  1638.         ch := target[i];
  1639.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1640.         if (quoteon or
  1641.           (
  1642.             (ch <> nul) and
  1643.             (
  1644.               (ch < linefeed) or (ch > creturn))
  1645.             )
  1646.         ) then begin
  1647.           inc(j);
  1648.           target[j] := ch
  1649.         end;
  1650.         inc(i)
  1651.       end;
  1652.       target[0] := chr(j)
  1653.     end;
  1654.     __cvtstr := target
  1655.   end;
  1656.  
  1657.  
  1658.  
  1659.  
  1660.   function __entabstr(source : string; incr : byte) : string;
  1661.   const
  1662.     blank = #32;
  1663.     tab   = #9;
  1664.  
  1665.   var
  1666.     column, numblanks : word;
  1667.     sourceidx         : word;
  1668.     targetidx         : word;
  1669.     thisch            : char;
  1670.  
  1671.   begin
  1672.     if ((length(source) = 0) or (incr <= 0)) then begin
  1673.       __entabstr := source;
  1674.       exit
  1675.     end;
  1676.  
  1677.     column    := 0;
  1678.     numblanks := 0;
  1679.     sourceidx := 0;
  1680.     targetidx := 0;
  1681.  
  1682.     repeat
  1683.       inc(sourceidx);
  1684.       thisch := source[sourceidx];
  1685.       case thisch of
  1686.         blank: begin
  1687.           inc(numblanks);
  1688.           inc(column);
  1689.           if ((incr <= 0) or (column mod incr = 0)) then begin
  1690.             inc(targetidx);
  1691.             if (numblanks > 1) then __entabstr[targetidx] := tab else
  1692.               __entabstr[targetidx] := blank;
  1693.             numblanks := 0
  1694.           end;
  1695.         end;
  1696.         tab: begin
  1697.           inc(targetidx);
  1698.           column                := 0;
  1699.           numblanks             := 0;
  1700.           __entabstr[targetidx] := tab
  1701.         end;
  1702.  
  1703.         else begin
  1704.           inc(column);
  1705.           inc(targetidx);
  1706.           while numblanks > 0 do begin
  1707.             __entabstr[targetidx] := blank;
  1708.             dec(numblanks);
  1709.             inc(targetidx)
  1710.           end;
  1711.           __entabstr[targetidx] := thisch
  1712.         end;
  1713.       end;
  1714.     until (sourceidx = length(source));
  1715.     __entabstr[0] := chr(targetidx)
  1716.   end;
  1717.  
  1718.  
  1719.  
  1720.  
  1721.   function __detabstr(
  1722.     source : string; incr : byte;
  1723.     var remstr : string
  1724.   ) : string;
  1725.  
  1726.   const
  1727.     tab   = #9;
  1728.     blank = #32;
  1729.  
  1730.   var
  1731.     numspaces : word;
  1732.     sourceidx : word;
  1733.     targetidx : word;
  1734.     len       : word;
  1735.     thisch    : char;
  1736.  
  1737.   begin
  1738.     if ((length(source) = 0) or (incr <= 0)) then begin
  1739.       __detabstr := source;
  1740.       remstr     := '';
  1741.       exit
  1742.     end;
  1743.  
  1744.     len       := 0;
  1745.     sourceidx := 0;
  1746.     targetidx := 0;
  1747.  
  1748.     repeat
  1749.       inc(sourceidx);
  1750.       thisch := source[sourceidx];
  1751.       if (thisch = tab) then begin
  1752.         numspaces := incr - (targetidx mod incr);
  1753.         if (numspaces > 0) then
  1754.            repeat
  1755.              inc(targetidx);
  1756.              dec(numspaces);
  1757.              if (targetidx <= maxstr_) then
  1758.                begin
  1759.                  len                   := targetidx;
  1760.                  __detabstr[targetidx] := blank
  1761.                end
  1762.              else
  1763.                numspaces := 0
  1764.            until (numspaces = 0);
  1765.       end else begin
  1766.         inc(targetidx);
  1767.         len := targetidx;
  1768.         __detabstr[targetidx] := thisch
  1769.       end;
  1770.     until ((sourceidx = length(source)) or (targetidx >= maxstr_));
  1771.     if (sourceidx < length(source)) then
  1772.       remstr := copy(source,sourceidx,maxstr_) else remstr := '';
  1773.     __detabstr[0] := chr(len)
  1774.   end;
  1775.  
  1776.  
  1777.  
  1778.  
  1779.  
  1780.  
  1781.   function __toradstr(
  1782.     intvalue : longint;
  1783.     size,radix,width : word
  1784.   ) : string;
  1785.  
  1786.   const
  1787.     max32bit = 4294967296.0;
  1788.  
  1789.   const
  1790.     radcheck : array[1..36] of char =
  1791.       '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  1792.  
  1793.   var
  1794.     quotient             : word;
  1795.     i, j, ival           : word;
  1796.     rval, rquotient      : real;
  1797.     remainder            : real;
  1798.     tempstr, returnedstr : string;
  1799.  
  1800.   begin
  1801.     if (
  1802.       (radix < 2) or (radix > 36) or
  1803.       (
  1804.         (size <> 1) and (size <> 2) and (size <> 4)
  1805.       )
  1806.     ) then begin
  1807.       __toradstr := '';
  1808.       exit
  1809.     end;
  1810.  
  1811.     i := 0;
  1812.     case size of
  1813.       1,2: begin
  1814.         if (size = 1) then ival := (intvalue shl 24) shr 24 else
  1815.           ival := (intvalue shl 16) shr 16;
  1816.         if (ival = 0) then returnedstr := '0' else repeat
  1817.           inc(i);
  1818.           quotient   := ival div radix;
  1819.           tempstr[i] := radcheck[(ival mod radix) + 1];
  1820.           ival       := quotient;
  1821.         until (ival = 0);
  1822.       end;
  1823.       4 : if (intvalue = 0) then returnedstr := '0' else begin
  1824.         if (intvalue < 0) then rval := intvalue + max32bit else
  1825.           rval := intvalue;
  1826.         repeat
  1827.           inc(i);
  1828.           rquotient := trunc(rval / radix);
  1829.           remainder := trunc(rval - radix * 1.0 * trunc(rval / radix));
  1830.           tempstr[i] := radcheck[round(remainder) + 1];
  1831.           rval := rquotient;
  1832.         until (rval = 0);
  1833.       end;
  1834.     end;
  1835.  
  1836.     returnedstr[0] := chr(i);
  1837.     for j := i downto 1 do returnedstr[j] := tempstr[i - j + 1];
  1838.  
  1839.     if ((width < length(returnedstr)) or (width > maxstr_)) then
  1840.       __toradstr := returnedstr else
  1841.       __toradstr := __juststr(returnedstr,'0',width,_right_just_str)
  1842.   end;
  1843.  
  1844.  
  1845.  
  1846.   function  __todecstr(intvalue : longint; size : word) : string;
  1847.   var width : word;
  1848.   begin
  1849.     case size of
  1850.       1 : width := 3;
  1851.       2 : width := 5;
  1852.       4 : width := 10;
  1853.       else exit;
  1854.     end;
  1855.     __todecstr := __toradstr(intvalue,size,10,width)
  1856.   end;
  1857.  
  1858.  
  1859.  
  1860.   function  __tohexstr(intvalue : longint; size : word) : string;
  1861.   const hexcheck : array[0..15] of char = '0123456789ABCDEF';
  1862.   var
  1863.     i       : integer;
  1864.     tempstr : string[8];
  1865.  
  1866.   begin
  1867.     if ((size <> 1) and (size <> 2) and (size <> 4)) then begin
  1868.       __tohexstr := '';
  1869.       exit
  1870.     end;
  1871.     tempstr[0] := chr(8);
  1872.     for i := 0 to 7 do begin
  1873.       tempstr[8 - i] := hexcheck[intvalue and $000f];
  1874.       intvalue := intvalue shr 4
  1875.     end;
  1876.     i := 2 * size;
  1877.     __tohexstr := copy(tempstr,8 - i + 1,i)
  1878.   end;
  1879.  
  1880.  
  1881.  
  1882.  
  1883.   function  __ptr2str(thisptr : pointer) : string;
  1884.   const colon = ':';
  1885.   begin
  1886.     __ptr2str :=
  1887.       __tohexstr(_vectoraddr(thisptr)._seg,sizeof(word)) + colon +
  1888.       __tohexstr(_vectoraddr(thisptr)._ofs,sizeof(word))
  1889.   end;
  1890.  
  1891.  
  1892.  
  1893.   function  __formstr(mask : string; x : real) : string;
  1894.   const
  1895.     space   = ' ';
  1896.     zero    = '0';
  1897.     right   = 1;
  1898.     left    = 2;
  1899.     inputchars : string[6] = '+-#@*';
  1900.  
  1901.   type
  1902.     signlogic = (default,plus,minus);
  1903.  
  1904.   var
  1905.     retstr    : string;
  1906.     fillch    : char;
  1907.     decch     : char;
  1908.     sepch     : char;
  1909.     signch    : char;
  1910.     i         : byte;
  1911.     j         : byte;
  1912.     intlen    : byte;
  1913.     decpos    : byte;
  1914.     start     : byte;
  1915.     endit     : byte;
  1916.     nfldsize  : byte;
  1917.     dplaces   : byte;
  1918.     signpos   : byte;
  1919.     signflg   : signlogic;
  1920.     done      : boolean;
  1921.     money     : boolean;
  1922.     innum     : boolean;
  1923.     negative  : boolean;
  1924.  
  1925.   begin
  1926.     if (mask = '') then begin
  1927.       __formstr := '';
  1928.       exit
  1929.     end;
  1930.  
  1931.     done       := false;
  1932.     innum      := false;
  1933.     money      := false;
  1934.     signflg    := default;
  1935.     negative   := x < 0;
  1936.     decpos     := 0;
  1937.     i          := 0;
  1938.     start      := 0;
  1939.     fillch     := space;
  1940.     sepch      := #0;
  1941.     decch      := #0;
  1942.     x          := abs(x);
  1943.     inputchars := inputchars + _strmoneych;
  1944.  
  1945.     repeat
  1946.       inc(i);
  1947.       if (
  1948.         ((innum) and ((mask[i] = '.') or (mask[i] = ',') or
  1949.         (mask[i] = space))) or (pos(mask[i],inputchars) > 0)
  1950.       ) then begin
  1951.         innum := true;
  1952.         if (start = 0) then start := i;
  1953.         if (mask[i] = '-') then begin
  1954.           signpos := i;
  1955.           signflg := minus
  1956.         end;
  1957.         if (mask[i] = '+') then begin
  1958.           signpos := i;
  1959.           signflg := plus
  1960.         end;
  1961.         if (mask[i] = _strmoneych) then money := true;
  1962.         if (mask[i] = '@') then if (fillch = space) then fillch := zero;
  1963.         if (mask[i] = '*') then fillch := '*';
  1964.         if ((mask[i] = '.') or (mask[i] = ',') or (mask[i] = space)) then
  1965.           if ((i = length(mask)) or (pos(mask[succ(i)],inputchars) < 3)) then
  1966.             done := true else if (mask[i] = space) then
  1967.               sepch := space else begin
  1968.                 if (decch <> #0) then sepch  := decch;
  1969.                 decch  := mask[i];
  1970.                 decpos := i
  1971.               end;
  1972.       end else if (innum) then done := true;
  1973.     until (i = length(mask)) or done;
  1974.  
  1975.     if (decch = sepch) then begin decpos := 0; decch  := #0 end;
  1976.     if (start = 0) then begin __formstr := mask; exit end;
  1977.     endit := i - ord(done);
  1978.     if (signflg <> default) then if (signpos = endit) then begin
  1979.       inc(decpos, ord(decpos > 0));
  1980.       signpos := right
  1981.     end else signpos := left;
  1982.  
  1983.     if (money) then if (fillch = zero) then fillch := space;
  1984.     nfldsize := succ(endit - start);
  1985.     if (decpos > 0) then begin
  1986.       decpos  := decpos - pred(start);
  1987.       dplaces := nfldsize - decpos
  1988.     end else dplaces := 0;
  1989.  
  1990.     str(x : 0 : dplaces, retstr);
  1991.     if (dplaces > 0) then begin
  1992.       dplaces := length(retstr) - pos('.',retstr);
  1993.       retstr[length(retstr) - dplaces] := decch
  1994.     end;
  1995.  
  1996.     j := 0;
  1997.     if (dplaces > 0) then intlen := length(retstr) - succ(dplaces) else
  1998.       intlen := length(retstr);
  1999.     if (sepch <> #0) then for i := intlen downto 2 do begin
  2000.       inc(j);
  2001.       if (j mod 3 = 0) then insert(sepch,retstr,i);
  2002.     end;
  2003.  
  2004.     if (negative) then signch := '-' else if (signflg = plus) then
  2005.       signch := '+' else signch := space;
  2006.  
  2007.     j := length(retstr) + ord(money) +
  2008.       ord((negative) or (signflg <> default));
  2009.  
  2010.     if (j > nfldsize) then begin
  2011.       for i := start to endit do
  2012.         if ((mask[i] = '+') or (mask[i] = '-')) then mask[i] := signch else
  2013.           if (not ((mask[i] = ',') or (mask[i] = '.') or
  2014.             (mask[i] = space))) then mask[i] := '*';
  2015.       __formstr := mask;
  2016.       exit
  2017.     end;
  2018.  
  2019.     if (money) then retstr := _strmoneych + retstr;
  2020.     if (signflg = default) then begin
  2021.       if ((negative) and (fillch = space)) then retstr := '-' + retstr;
  2022.       while length(retstr) < nfldsize do insert(fillch,retstr,1)
  2023.     end else begin
  2024.       case signpos of
  2025.         right : retstr := retstr + signch;
  2026.         left  : retstr := signch + retstr;
  2027.       end;
  2028.       while length(retstr) < nfldsize do insert(fillch,retstr,signpos)
  2029.     end;
  2030.  
  2031.     if (start > 1) then retstr := copy(mask,1,pred(start)) + retstr;
  2032.     if (endit < length(mask)) then
  2033.       retstr := retstr + copy(mask,succ(endit),length(mask));
  2034.     __formstr := retstr
  2035.   end;
  2036.  
  2037.  
  2038.  
  2039.   function openfmt__(var fmtfil : textrec) : integer;
  2040.   begin
  2041.     with textrec(fmtfil) do begin
  2042.       if (mode <> fmoutput) then begin
  2043.         openfmt__ := 105;
  2044.         exit;
  2045.       end;
  2046.       getmem(bufptr,_fmt_buflen_str);
  2047.       if (bufptr = nil) then begin
  2048.         openfmt__ := 203;
  2049.         exit;
  2050.       end;
  2051.       bufsize := _fmt_buflen_str;
  2052.       bufpos  := 0;
  2053.       bufend  := 0;
  2054.     end;
  2055.     openfmt__ := 0
  2056.   end;
  2057.  
  2058.  
  2059.  
  2060.  
  2061.   function closefmt__(var fmtfil : textrec) : integer;
  2062.   begin
  2063.     with textrec(fmtfil) do begin
  2064.       freemem(bufptr,_fmt_buflen_str);
  2065.       mode := fmclosed;
  2066.     end;
  2067.     closefmt__ := 0;
  2068.   end;
  2069.  
  2070.  
  2071.  
  2072.  
  2073.   function inoutfmt__(var fmtfil : textrec) : integer;
  2074.   begin
  2075.     with textrec(fmtfil) do begin
  2076.       if (bufpos >= _fmt_buflen_str) then inoutfmt__ := 101 else
  2077.         inoutfmt__ := 0;
  2078.     end;
  2079.   end;
  2080.  
  2081.  
  2082.  
  2083.   procedure __initfstr(var fmtfil : text);
  2084.   begin
  2085.     with textrec(fmtfil) do begin
  2086.       handle    := $ffff;
  2087.       mode      := fmclosed;
  2088.       bufsize   := 0;
  2089.       bufptr    := nil;
  2090.       openfunc  := @openfmt__;
  2091.       inoutfunc := @inoutfmt__;
  2092.       flushfunc := @inoutfmt__;
  2093.       closefunc := @closefmt__;
  2094.       name[0]   := #0;
  2095.       rewrite(fmtfil)
  2096.     end;
  2097.   end;
  2098.  
  2099.  
  2100.  
  2101.  
  2102.   function  __retbfstr(var fmtfil : text) : string;
  2103.   var
  2104.     s : string;
  2105.     i : word;
  2106.  
  2107.   begin
  2108.     with textrec(fmtfil) do begin
  2109.       if (mode = fmoutput) then begin
  2110.         i := bufpos; if (i > 255) then i := 255;
  2111.         move(bufptr^,s[1],i);
  2112.         s[0]   := char(i);
  2113.         bufpos := 0;
  2114.         bufend := 0;
  2115.       end else s[0] := #0;
  2116.     end;
  2117.     __retbfstr := s;
  2118.   end;
  2119.  
  2120.  
  2121.  
  2122.  
  2123.  
  2124.  
  2125.  
  2126.  
  2127.  
  2128.  
  2129.  
  2130. { SECONDARY STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2131.   procedure  __app(var st: string; aps: string);
  2132.   begin
  2133.     st := st + aps;
  2134.   end;
  2135.  
  2136.  
  2137.   function  __backapp(s: string) : string;
  2138.   begin
  2139.     if s[length(s)] <> _dirslash then __backapp := s + _dirslash else
  2140.       __backapp := s;
  2141.   end;
  2142.  
  2143.  
  2144.   function  __backrem(s: string) : string;
  2145.   begin
  2146.     if s[length(s)] in ['\', _dirslash] then __backrem := copy(s, 1, length(s)-1) else
  2147.       __backrem := s;
  2148.   end;
  2149.  
  2150.  
  2151.   function __lastchr(s: string): char;
  2152.   begin
  2153.     __lastchr := s[length(s)];
  2154.   end;
  2155.  
  2156.  
  2157.   function __comp(s1, s2: string): boolean;
  2158.   begin
  2159.     __comp := (
  2160.       __cvtstr(s1, _rem_white_str + _to_upcase_str) =
  2161.       __cvtstr(s2, _rem_white_str + _to_upcase_str)
  2162.     )
  2163.   end;
  2164.  
  2165.  
  2166.  
  2167.  
  2168.   function __hexdecstr;
  2169.   var
  2170.     v : longint;
  2171.     i : shortint;
  2172.  
  2173.    {
  2174.     converts a hexadecimal string into an integer, ready to
  2175.     be processed by __toradstr into the diverse formats
  2176.    }
  2177.  
  2178.     function __power(x,y: integer): longint;
  2179.     begin
  2180.       if x>0 then
  2181.       __power := round(exp(y*ln(x))) else if x<0 then
  2182.         __power := -1 * (y mod 2) * round(exp(y*ln(x)));
  2183.     end;
  2184.  
  2185.  
  2186.     function hexvalue(inchar: char): shortint;
  2187.     begin
  2188.       if ord(inchar) in [65..70] then hexvalue := ord(inchar) - 55
  2189.       else hexvalue := ord(inchar) - 48
  2190.     end;
  2191.  
  2192.   begin
  2193.     v := 0; for i := length(hexstr) downto 1 do
  2194.       v := v + trunc(__power(16,length(hexstr)-i)*hexvalue(upcase(hexstr[i])));
  2195.     __hexdecstr := v
  2196.   end;
  2197.  
  2198.  
  2199.  
  2200.   function  __lo(s: string): string;
  2201.   begin
  2202.     __lo := __cvtstr(s, _to_lowcase_str);
  2203.   end;
  2204.  
  2205.  
  2206.   function  __min(v1, v2: longint): longint;
  2207.   begin
  2208.     if v1 <= v2 then __min := v1 else __min := v2;
  2209.   end;
  2210.  
  2211.  
  2212.   function __num(nr: longint):string;
  2213.   var temp: string;
  2214.   begin
  2215.     str(nr,temp); __num := temp;
  2216.   end;
  2217.  
  2218.  
  2219.  
  2220.   function __real(st: string): real;
  2221.   var
  2222.     code : integer;
  2223.     temp :    real;
  2224.   begin
  2225.     if length(st)=0 then __real := 0 else begin
  2226.       val(st, temp, code);
  2227.       if code = 0 then __real := temp else __real := 0;
  2228.     end;
  2229.   end;
  2230.  
  2231.  
  2232.  
  2233.   function __streal(nr: real; decs: byte): string;
  2234.   var
  2235.     tm1, tm2 : string;
  2236.  
  2237.   begin
  2238.     tm1 := __num(trunc(nr));
  2239.     tm2 := __num(
  2240.       round(
  2241.         (
  2242.           nr - trunc(nr)
  2243.         )
  2244.         *
  2245.         __power(10, decs)
  2246.       )
  2247.     );
  2248.     __streal := tm1 + '.' + tm2;
  2249.   end;
  2250.  
  2251.  
  2252.   function __nw(s: string): string;
  2253.   begin
  2254.     __nw := __cvtstr(s, _rem_white_str);
  2255.   end;
  2256.  
  2257.  
  2258.   function __overtype(n:byte;strs,strt:string):string;
  2259.  
  2260.   var
  2261.     l : byte;
  2262.     strn : string;
  2263.  
  2264.   begin
  2265.     l := n + pred(length(strs));
  2266.     if l < length(strt) then l := length(strt);
  2267.     if l > 255 then __overtype := copy(strt,1,pred(n)) +
  2268.       copy(strs,1,255-n) else begin
  2269.       fillchar(strn[1],l,' ');
  2270.       strn[0] := chr(l);
  2271.       move(strt[1],strn[1],length(strt));
  2272.       move(strs[1],strn[n],length(strs));
  2273.       __overtype := strn;
  2274.     end;
  2275.   end;
  2276.  
  2277.  
  2278.  
  2279.  
  2280.   function __pntstr(n: longint): string;
  2281.   var
  2282.     tmpnrstr,
  2283.     tmpcvtstr   :  string;
  2284.     tab, i,
  2285.     len_numstr,
  2286.     len_pnts    : longint; 
  2287.  
  2288.   begin
  2289.     str(n, tmpnrstr); tab := 0;
  2290.     len_numstr := length(tmpnrstr);
  2291.     len_pnts := (len_numstr -1) div 3;
  2292.     tmpcvtstr[0] := chr(len_numstr + len_pnts);
  2293.  
  2294.     tmpcvtstr[len_pnts +len_numstr -tab] := tmpnrstr[len_numstr];
  2295.     for i := len_numstr-1 downto 1 do begin
  2296.       if ((len_numstr -i) mod 3 =0) then begin
  2297.         tmpcvtstr[len_pnts +i -tab] := '.'; inc(tab)
  2298.       end;
  2299.       tmpcvtstr[len_pnts +i -tab] := tmpnrstr[i];
  2300.     end;
  2301.     __pntstr := copy(tmpcvtstr, 1, len_numstr +len_pnts);
  2302.   end;
  2303.  
  2304.  
  2305.  
  2306.  
  2307.   function __str(st: string): integer;
  2308.   var
  2309.     code, temp: integer;
  2310.   begin
  2311.     if length(st)=0 then __str := 0 else begin
  2312.       val(st, temp, code);
  2313.       if code=0 then __str := temp else __str := 0;
  2314.     end;
  2315.   end;
  2316.  
  2317.  
  2318.  
  2319.  
  2320.   function  __up(s: string): string;
  2321.   begin
  2322.     __up := __cvtstr(s, _to_upcase_str);
  2323.   end;
  2324.  
  2325.  
  2326.   function  __uprem(s: string): string;
  2327.   begin
  2328.     __uprem := __cvtstr(s, _to_upcase_str + _rem_white_str);
  2329.   end;
  2330.  
  2331.  
  2332.   function __val(st: string): longint;
  2333.   var
  2334.     code: integer;
  2335.     temp: longint;
  2336.  
  2337.   begin
  2338.     if length(st)=0 then __val := 0 else begin
  2339.       val(st, temp, code);
  2340.       if code=0 then __val := temp else __val := 0;
  2341.     end;
  2342.   end;
  2343.  
  2344.  
  2345.  
  2346.  
  2347.  
  2348.   function  __nonascii(s: string): boolean;
  2349.   var
  2350.     i     :    byte;
  2351.     __b__ : boolean;
  2352.  
  2353.   begin
  2354.     __b__ := false;
  2355.     for i := 1 to length(s) do 
  2356.       __b__ := __b__ or (ord(s[i]) in [0..31,128..255]);
  2357.     __nonascii := __b__
  2358.   end;
  2359.  
  2360.  
  2361.  
  2362.   function __killnonascii(s: string): string;
  2363.   var
  2364.     __st__ : string;
  2365.     i      :   byte;
  2366.  
  2367.   begin
  2368.     __st__ := '';
  2369.     for i := 1 to length(s) do
  2370.       if (ord(s[i]) in [32, 127]) then 
  2371.         __st__ := __st__ + s[i];
  2372.     __killnonascii := __st__;
  2373.   end;
  2374.  
  2375.  
  2376.  
  2377.  
  2378.  
  2379. { PRIMARY BYTE CONVERSION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2380.   function __byte2str(b: byte): str8;
  2381.   var
  2382.     s: str8;
  2383.     i: byte;
  2384.  
  2385.   begin
  2386.     s := __rep(8, nonblock); i := b;
  2387.     if (i and $01) > 0 then s[1] := block;
  2388.     if (i and $02) > 0 then s[2] := block;
  2389.     if (i and $04) > 0 then s[3] := block;
  2390.     if (i and $08) > 0 then s[4] := block;
  2391.     if (i and $10) > 0 then s[5] := block;
  2392.     if (i and $20) > 0 then s[6] := block;
  2393.     if (i and $40) > 0 then s[7] := block;
  2394.     if (i and $80) > 0 then s[8] := block;
  2395.     __byte2str := s
  2396.   end;
  2397.  
  2398.  
  2399.  
  2400.   function __str2byte(s: str8): byte;
  2401.   var l, b: byte;
  2402.   begin
  2403.     l := 0;
  2404.     for b := 1 to 8 do begin
  2405.       l := l shl 1; if not(s[b] in [nonblock, ' ', '-']) then inc(l)
  2406.     end;
  2407.     __str2byte := l;
  2408.   end;
  2409.  
  2410.  
  2411.  
  2412.  
  2413.   {
  2414.     representation 4 user flags, array[1..4] of byte
  2415.     by a string[32], or a longint
  2416.  
  2417.  
  2418.          ·····■·■■·■■·■·■·■·■■■····■■·■·■  =  longint
  2419.          └──fD──┘└──fC──┘└──fB──┘└──fA──┘
  2420.            str8    str8    str8    str8
  2421.            byte    byte    byte    byte
  2422.  
  2423.          │                              │
  2424.          2^31                           1
  2425.  
  2426.     bit 31 (32nd bit) is complementory represented.
  2427.     ( -maxlongint-1 )
  2428.   }
  2429.  
  2430.  
  2431.  
  2432.   function __longint2str(l: longint): str32;
  2433.   const con: array[1..31] of longint = (
  2434.     $00000001, $00000002, $00000004, $00000008,
  2435.     $00000010, $00000020, $00000040, $00000080,
  2436.     $00000100, $00000200, $00000400, $00000800,
  2437.     $00001000, $00002000, $00004000, $00008000,
  2438.     $00010000, $00020000, $00040000, $00080000,
  2439.     $00100000, $00200000, $00400000, $00800000,
  2440.     $01000000, $02000000, $04000000, $08000000,
  2441.     $10000000, $20000000, $40000000
  2442.   );
  2443.   var
  2444.     s : str32;
  2445.     b :  byte;
  2446.  
  2447.   begin
  2448.     s := __rep(32, nonblock); if l < 0 then s[32-31] := block;
  2449.     if l < 0 then l := l + maxlongint + 1;
  2450.     for b := 1 to 31 do if (l and con[b]) >0 then s[32-b+1] := block;
  2451.     __longint2str := s
  2452.   end;
  2453.  
  2454.  
  2455.  
  2456.   function __str2longint(s: str32): longint;
  2457.   var
  2458.     l : longint;
  2459.     b :    byte;
  2460.  
  2461.   begin
  2462.     l := 0;
  2463.     for b := 2 to 32 do begin
  2464.       l := l shl 1; if not(s[b] in [nonblock, ' ', '-']) then inc(l)
  2465.     end;
  2466.     if not(s[1] in [nonblock, ' ', '-']) then l := l - maxlongint - 1;
  2467.     __str2longint := l;
  2468.   end;
  2469.  
  2470.  
  2471.  
  2472.  
  2473.  
  2474.  
  2475.  
  2476.  
  2477. { ASCIIZ AND OTHER FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2478.   procedure __str2obj(s: anystr; var a; length_a: integer );
  2479.   var
  2480.     i  : integer;
  2481.     aa : packed array[ 1 .. 1 ] of char absolute a;
  2482.  
  2483.   begin
  2484.     fillchar(aa[1], length_a, ' ');
  2485.     move(s[1], aa[1], __min(length_a, length(s)));
  2486.   end;
  2487.  
  2488.  
  2489.   procedure __str2arr(s: anystr; var a; length_a: integer );
  2490.   var
  2491.     i     : integer;
  2492.     len_s : integer;
  2493.     len_a : integer;
  2494.     l     : integer;
  2495.     aa    : packed array[ 1 .. 1 ] of char absolute a;
  2496.  
  2497.   begin
  2498.     len_s := length( s ); len_a := length_a; l := __min(len_a, len_s);
  2499.     for i := 1 to l do begin
  2500.       aa[len_a] := s[len_s]; dec(len_a); dec(len_s)
  2501.     end;
  2502.     for i := len_a downto 1 do aa[i] := ' ';
  2503.   end;
  2504.  
  2505.  
  2506.   function __readctrls(s: anystr): anystr;
  2507.   var
  2508.     t : anystr;
  2509.     i : integer;
  2510.     j : integer;
  2511.     l : integer;
  2512.  
  2513.   begin
  2514.     t:=''; i:=1; j:=0; l:=length(s);
  2515.     while( i <= l ) do begin
  2516.       if ( s[i] = fk_ctrl_mark ) then if ( s[i+1] <> '''' ) then begin
  2517.         inc(i); inc(j); t[j]:=chr( ord(s[i])-64); inc(i)
  2518.       end else begin
  2519.         inc(j); t[j]:=s[i]; t[j+1]:=s[i+1]; t[j+2]:=s[i+2]; inc(i,3); inc(j,2);
  2520.       end else begin
  2521.         inc( j ); t[j]:=s[i]; inc(i)
  2522.       end;
  2523.     end; t[0]:=chr( j ); __readctrls:=t;
  2524.   end;
  2525.  
  2526.  
  2527.  
  2528.   function __writectrls(s: anystr): anystr;
  2529.   var
  2530.     t: anystr;
  2531.     i: integer;
  2532.     j: integer;
  2533.  
  2534.   begin
  2535.     t:=''; j := 0;
  2536.     for i:=1 to length( s ) do begin
  2537.       if ( s[i] in [^@..^_] ) then begin
  2538.         inc(j); t[j] := fk_ctrl_mark; inc(j); t[j] := chr(ord(s[i])+64);
  2539.       end else begin
  2540.         inc(j); t[j]:=s[i]
  2541.       end;
  2542.     end; t[0]:=chr( j ); __writectrls := t;
  2543.   end;
  2544.  
  2545.  
  2546.   function __az2str(a: asciiz): string;
  2547.   var s : string; slen: byte absolute s;
  2548.   begin
  2549.     slen:=0; while a[slen] <> #0 do slen:=succ(slen); move(a, s[1], slen);
  2550.     __az2str:=s;
  2551.   end;
  2552.  
  2553.  
  2554.   procedure __str2az(s : string; var a : asciiz);
  2555.   var slen: byte absolute s;
  2556.   begin
  2557.     move(s[1], a, slen); a[slen]:=#0;
  2558.   end;
  2559.  
  2560.  
  2561.  
  2562.  
  2563.  
  2564.  
  2565.  
  2566. { STRING1024 FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2567.   procedure __app1024(var app: ar1024; s: string);
  2568.   var i, j : word;
  2569.   begin
  2570.     i := 1; while (app[i] <> #0) and (i < 1024) do inc(i);
  2571.     for j := 1 to length(s) do begin app[i + j - 1] := s[j] end;
  2572.   end;
  2573.  
  2574.  
  2575.  
  2576.   function __len1024(var a: ar1024) : word;
  2577.   var l : word;
  2578.   begin
  2579.     l := 1;
  2580.     while (l < 1024) and (a[l] <> #0) do inc(l); dec(l);
  2581.     __len1024 := l;
  2582.   end;
  2583.  
  2584.  
  2585.  
  2586.   procedure __clr1024(var a: ar1024);
  2587.   begin
  2588.     fillchar(a, sizeof(ar1024), #0);
  2589.   end;
  2590.  
  2591.  
  2592.   procedure __del1024(var a: ar1024; b, l: word);
  2593.   begin
  2594.     move(a[b+l], a[b], 1024 - b)
  2595.   end;
  2596.  
  2597.  
  2598.   procedure __ins1024(var a: ar1024; b : word; s: string);
  2599.   var l, i : byte;
  2600.   begin
  2601.     l := length(s);
  2602.     move(a[b], a[b+l], 1024 - b);
  2603.     for i := 1 to l do a[b + i - 1] := s[i];
  2604.   end;
  2605.  
  2606.  
  2607.   procedure __write1024(var a: ar1024);
  2608.   var l : word;
  2609.   begin
  2610.     l := 1;
  2611.     while (l < 1024) and (a[l] <> #0) do begin write(a[l]); inc(l) end;
  2612.   end;
  2613.  
  2614.  
  2615.  
  2616.  
  2617.  
  2618.  
  2619.  
  2620.  
  2621.  
  2622.  
  2623. { PRIMARY DATA CONVERSION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2624.   function __main(b: longint; w: word): longint;
  2625.   begin
  2626.     if b mod w = 0 then __main := b else __main := ((b div w) + 1) * w
  2627.   end;
  2628.  
  2629.  
  2630.   function  __max(v1, v2: longint): longint;
  2631.   begin
  2632.     if v1 >= v2 then __max := v1 else __max := v2;
  2633.   end;
  2634.  
  2635.  
  2636.   function __power(x,y: integer): longint;
  2637.   begin
  2638.     if x>0 then
  2639.     __power := round(exp(y*ln(x))) else if x<0 then
  2640.       __power := -1 * (y mod 2) * round(exp(y*ln(x)));
  2641.   end;
  2642.  
  2643.  
  2644.  
  2645.   procedure __iptrsup(var p : pointer; n : longint);
  2646.   var seg,ofs : word;
  2647.   begin
  2648.     seg := n shr 4;                    { divide by 16 for paragraphs    }
  2649.     ofs := n mod 16;                   { offset                         }
  2650.     inc(seg,_vectoraddr(p)._seg);
  2651.     inc(ofs,_vectoraddr(p)._ofs);
  2652.     p := ptr(seg + (ofs shr 4),ofs and $000f)
  2653.   end;
  2654.  
  2655.  
  2656.   procedure __dptrsup(var p : pointer; n : longint);
  2657.   var seg,ofs : word;
  2658.   begin {__dptrsup}
  2659.     seg := n shr 4;                    { divide by 16 for paragraphs    }
  2660.     ofs := n mod 16;                   { offset                         }
  2661.     p := __nptrsup(ptr(_vectoraddr(p)._seg - seg,
  2662.                        _vectoraddr(p)._ofs - ofs))
  2663.   end;  {__iptrsup}
  2664.  
  2665.  
  2666.   function __nptrsup(thisptr : pointer) : pointer;
  2667.   begin {__nptrsup}
  2668.     __nptrsup := ptr(_vectoraddr(thisptr)._seg +
  2669.       (_vectoraddr(thisptr)._ofs shr 4),
  2670.       _vectoraddr(thisptr)._ofs and $f)
  2671.   end;
  2672.  
  2673.  
  2674.   function __ptr2lsup(thisptr : pointer) : longint;
  2675.   var normptr : pointer;
  2676.   begin
  2677.     normptr    := __nptrsup(thisptr);
  2678.     __ptr2lsup := (longint(_vectoraddr(normptr)._seg) shl 4) +
  2679.                                     longint(_vectoraddr(normptr)._ofs)
  2680.   end;
  2681.  
  2682.  
  2683.   procedure __fillwsup(var target; count : longint; fillword : word); external;
  2684.   procedure __fillbsup(var target; count : longint; fillbyte : byte); external;
  2685.  
  2686.   procedure __repmsup(var target,source; count : longint; sourcesize : word);
  2687.   var
  2688.     targetptr : pointer;
  2689.     i         : longint;
  2690.  
  2691.   begin
  2692.     if (count <= 0) then exit;
  2693.     case sourcesize of
  2694.       0 : exit;
  2695.       1 : __fillbsup(target,count,byte(source));
  2696.       2 : __fillwsup(target,count,word(source));
  2697.       else begin
  2698.         targetptr := @target;
  2699.         for i := 1 to count do begin
  2700.           move(source,targetptr^,sourcesize);
  2701.           __iptrsup(targetptr,sourcesize)
  2702.         end
  2703.       end;
  2704.     end  {case sourcesize}
  2705.   end;  {__repmsup}
  2706.  
  2707.  
  2708.   function __alphasup(ch : char) : boolean;
  2709.   begin
  2710.     if (
  2711.       ((ch > #64) and (ch < #91)) or ((ch > #96) and (ch < #123))
  2712.     ) then __alphasup := true else __alphasup := false;
  2713.   end;
  2714.  
  2715.  
  2716.  
  2717.  
  2718.  
  2719.  
  2720.  
  2721.  
  2722.  
  2723. { DATE FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2724.   function __datestr(var year,month,day : word) : string;
  2725.   const
  2726.     blank      = #32;
  2727.     comma      = #44;
  2728.  
  2729.   var
  2730.     dayofweek  : word;
  2731.     yearstr    : string[5];
  2732.     daystr     : string[2];
  2733.  
  2734.   begin
  2735.     getdate(year,month,day,dayofweek);
  2736.     str(year:5,yearstr);
  2737.     str(day,daystr);
  2738.     __datestr := _strdays[dayofweek] + blank + _strmonths[month] +
  2739.       blank + daystr + comma + yearstr;
  2740.   end;
  2741.  
  2742.  
  2743.   function  __timestr(
  2744.     var hours, minutes,
  2745.     seconds, tics : word
  2746.   ) : string;
  2747.   var
  2748.     tmphours,tmpmins : word;
  2749.  
  2750.   begin
  2751.     gettime(hours,minutes,seconds,tics);
  2752.     tmphours := hours;
  2753.     tmpmins  := minutes;
  2754.     if (seconds > 30) then begin
  2755.       tmpmins := succ(tmpmins) mod 60;
  2756.       if (tmpmins = 0) then tmphours := succ(tmphours) mod 24
  2757.     end;
  2758.     __timestr := __time2str(tmphours,tmpmins,seconds,0,_standard_str);
  2759.   end;
  2760.  
  2761.  
  2762.  
  2763.   function __dt2ststr(
  2764.     year    : word;
  2765.     month   : word;
  2766.     day     : word;
  2767.     datefmt : word
  2768.   ) : string;
  2769.  
  2770.   const
  2771.     blank = #32;
  2772.     zero  = #48;
  2773.     comma = #44;
  2774.  
  2775.   const
  2776.     strdays: array[1..12] of word = (31,29,31,30,31,30,31,31,30,31,30,31);
  2777.  
  2778.   var
  2779.     yrstr  : string[4];
  2780.     mnstr  : string[2];
  2781.     dystr  : string[2];
  2782.  
  2783.   begin
  2784.     __dt2ststr := '';
  2785.     if (year < 100) then inc(year,1900);
  2786.     if ((month < 1) or (month > 12)) then exit;
  2787.     if (((month = 2) and (day = 29)) and ((year mod 4) <> 0)) then exit;
  2788.     if ((day = 0) or (day > strdays[month])) then exit;
  2789.     str(year,yrstr); str(month:2,mnstr); str(day:2,dystr);
  2790.  
  2791.     if (yrstr[3] = blank) then yrstr[3] := zero;
  2792.     if (mnstr[1] = blank) then mnstr[1] := zero;
  2793.     if (dystr[1] = blank) then dystr[1] := zero;
  2794.  
  2795.     case datefmt of
  2796.       _usa_dt_str: begin
  2797.         __dt2ststr := mnstr + _strusach  + dystr +
  2798.           _strusach + copy(yrstr,3,2);
  2799.       end;
  2800.  
  2801.       _euro_dt_str: begin
  2802.         __dt2ststr := dystr + _streuroch + mnstr +
  2803.           _streuroch + copy(yrstr,3,2);
  2804.       end;
  2805.  
  2806.       _year_dt_str: begin
  2807.         __dt2ststr := mnstr + _strusach + dystr +
  2808.           _strusach + yrstr;
  2809.       end;
  2810.  
  2811.       _mont_dt_str: begin
  2812.         __dt2ststr := dystr + blank + copy(_strmonths[month],1,3) +
  2813.           blank + copy(yrstr,3,2);
  2814.      end;
  2815.  
  2816.       _form_dt_str: begin
  2817.         str(day,dystr);
  2818.         __dt2ststr := _strmonths[month] + blank + dystr +
  2819.           comma + blank + yrstr;
  2820.       end
  2821.     end;
  2822.   end;
  2823.  
  2824.  
  2825.  
  2826.   procedure __st2dtstr(st: string; var year, month, day: word; datefmt: word);
  2827.  
  2828.     function rettoken(
  2829.       var datestr : string;
  2830.       var start : word
  2831.     ) : string;
  2832.  
  2833.     var
  2834.       stop  : boolean;
  2835.       chpos : word;
  2836.  
  2837.     begin
  2838.       rettoken := '';
  2839.       stop  := false;
  2840.       chpos := start;
  2841.       while (
  2842.         (chpos <= length(datestr)) and
  2843.         (datestr[chpos] in ['a'..'z','A'..'Z','0'..'9'])
  2844.       ) do inc(chpos);
  2845.       rettoken := copy(datestr,start,chpos - start);
  2846.       start    := succ(chpos);
  2847.     end;
  2848.  
  2849.  
  2850.   var
  2851.     token   : string[9];
  2852.     temp1   : word;
  2853.     temp2   : word;
  2854.     start   : word;
  2855.     errcode : word;
  2856.     i       : word;
  2857.     match   : boolean;
  2858.  
  2859.   begin
  2860.     month := 0; day   := 0; year  := 0;
  2861.     start := 1;
  2862.     token := rettoken(st,start);
  2863.     case datefmt of
  2864.       _usa_dt_str,
  2865.       _euro_dt_str,
  2866.       _year_dt_str,
  2867.       _mont_dt_str : begin
  2868.         val(token,temp1,errcode);
  2869.         if (errcode <> 0) then exit;
  2870.       end;
  2871.  
  2872.       _form_dt_str : begin
  2873.         i := 1;
  2874.         repeat
  2875.           match := (
  2876.             __cvtstr(token,_to_upcase_str) =
  2877.             __cvtstr(_strmonths[i],_to_upcase_str)
  2878.           );
  2879.           inc(i);
  2880.         until ((i > 12) or (match));
  2881.         if (match) then temp1 := pred(i) else exit;
  2882.       end
  2883.     end;
  2884.  
  2885.     token := rettoken(st, start);
  2886.     case datefmt of
  2887.       _usa_dt_str,
  2888.       _euro_dt_str,
  2889.       _year_dt_str,
  2890.       _form_dt_str : begin
  2891.         val(token,temp2,errcode);
  2892.         if (errcode <> 0) then exit;
  2893.         if (datefmt = _form_dt_str) then inc(start);
  2894.       end;
  2895.       _mont_dt_str : begin
  2896.         i := 1;
  2897.         repeat
  2898.           match := (
  2899.             __cvtstr(token,_to_upcase_str) =
  2900.             __cvtstr(copy(_strmonths[i],1,3), _to_upcase_str)
  2901.           );
  2902.           inc(i);
  2903.         until ((i > 12) or (match));
  2904.         if (match) then temp2 := pred(i) else exit;
  2905.       end;
  2906.     end;
  2907.     token := rettoken(st,start);
  2908.     val(token,year,errcode);
  2909.     if (errcode <> 0) then exit;
  2910.     if (year < 100) then inc(year,1900);
  2911.     case datefmt of
  2912.       _euro_dt_str,
  2913.       _mont_dt_str  : begin
  2914.         month := temp2;
  2915.         day   := temp1
  2916.       end else begin
  2917.         month := temp1;
  2918.         day   := temp2
  2919.       end;
  2920.     end;
  2921.   end;
  2922.  
  2923.  
  2924.  
  2925.   function __time2str(
  2926.     hours, mins : word;
  2927.     secs, tics : word;
  2928.     format : word
  2929.   ) : string;
  2930.  
  2931.   const
  2932.     colon     = ':';
  2933.     period    = '.';
  2934.     point     = '·';
  2935.     space     = ' ';
  2936.     zero      = '0';
  2937.     dirbit    = $0010;
  2938.  
  2939.   var
  2940.     ahrs    : word;
  2941.     i       : word;
  2942.     hstr    : string[2];
  2943.     mstr    : string[2];
  2944.     sstr    : string[2];
  2945.     tstr    : string[2];
  2946.     timestr : string[14];
  2947.  
  2948.   begin
  2949.     hours := hours mod 24;
  2950.     ahrs  := hours;
  2951.     if ((_12hour_str and format) <> 0) then begin
  2952.       if (hours = 0) then hours := 12 else if (hours > 12) then dec(hours,12);
  2953.     end;
  2954.     str(hours,hstr); str((mins mod 60):2,mstr);
  2955.     timestr := hstr + colon + mstr;
  2956.     if ((_inc_sec_str and format) <> 0) then begin
  2957.       str((secs mod 60):2,sstr);
  2958.       timestr := timestr + period + sstr;
  2959.     end;
  2960.     if ((_inc_tic_str and format) <> 0) then begin
  2961.       str((tics mod 100):2,tstr);
  2962.       timestr := timestr + point + tstr;
  2963.     end;
  2964.     for i := 3 to length(timestr) do if (timestr[i] = space) then
  2965.       timestr[i] := zero;
  2966.     if ((_inc_ampm_str and format) <> 0) then
  2967.       timestr := timestr + _ampm_str[ahrs div 12] else
  2968.         if ((dirbit and format) <> 0) then
  2969.           timestr := timestr + _ap_str[succ(ahrs div 12)];
  2970.     __time2str := timestr;
  2971.   end;
  2972.  
  2973.  
  2974.  
  2975.   function __2timestr(
  2976.     timestr : string;
  2977.     var hours,mins : word;
  2978.     var secs,tics : word
  2979.   ) : boolean;
  2980.  
  2981.   const
  2982.     colon     = ':';
  2983.     period    = '.';
  2984.  
  2985.   var
  2986.     i         : word;
  2987.     len       : word;
  2988.     startpos  : word;
  2989.     endpos    : word;
  2990.     ch        : char;
  2991.     errorcode : word;
  2992.     values    : array[1..4] of word;
  2993.  
  2994.   begin
  2995.     __2timestr := false;
  2996.     fillchar(values,sizeof(values),0);
  2997.     len := length(timestr);
  2998.     if (len = 0) then exit;
  2999.     endpos := 0;
  3000.     for i := 1 to 4 do begin
  3001.       startpos := succ(endpos);
  3002.       repeat
  3003.         inc(endpos);
  3004.         ch := timestr[endpos];
  3005.       until ((ch = colon) or (ch = period) or (endpos > len));
  3006.       if ((endpos - startpos) > 0) then begin
  3007.         val(
  3008.           copy(timestr,startpos,endpos - startpos),
  3009.           values[i], errorcode
  3010.         );
  3011.         if (errorcode <> 0) then exit;
  3012.       end;
  3013.     end;
  3014.     hours := values[1]; mins := values[2];
  3015.     secs := values[3]; tics := values[4];
  3016.  
  3017.     if (
  3018.       (values[1] > 23) or (values[2] > 59) or (values[3] > 59) or
  3019.       (values[4] > 99)
  3020.     ) then exit;
  3021.     __2timestr := true;
  3022.   end;
  3023.  
  3024.  
  3025.  
  3026.   function __retdowstr(dayofweek: word; ful: boolean): string;
  3027.   begin
  3028.     if ful then __retdowstr := _strdays[dayofweek] else
  3029.       __retdowstr := copy(_strdays[dayofweek], 1, 3);
  3030.   end;
  3031.  
  3032.  
  3033.   function __todaystr(ful: boolean): string;
  3034.   var y, m, d, dow: word;
  3035.   begin
  3036.     getdate(y, m, d, dow);
  3037.     if ful then __todaystr := _strdays[dow] else
  3038.       __todaystr := copy(_strdays[dow], 1, 3);
  3039.   end;
  3040.  
  3041.  
  3042.   procedure __jl2dtutl(julian: longint; var year, month, day, weekday: word);
  3043.   var temp1 : longint;
  3044.   begin
  3045.     year := 0; month := 0; day := 0; weekday := 0;
  3046.     if (julian < 0) or (julian > 72989) then exit;
  3047.     temp1 := julian * 4 + 3;
  3048.     year  := (temp1 div 1461) + 1900;
  3049.     temp1 := ((temp1 mod 1461) div 4 + 1) * 5 - 3;
  3050.     month := temp1 div 153;
  3051.     day   := temp1 mod 153 div 5 + 1;
  3052.     if (month < 10) then inc(month,3) else begin dec(month,9); inc(year) end;
  3053.     weekday := (julian + 4) mod 7;
  3054.   end;
  3055.  
  3056.  
  3057.   function  __dt2jlutl(year, month, day : word) : longint;
  3058.   const days : array[1..12] of word = (31,29,31,30,31,30,31,31,30,31,30,31);
  3059.   begin
  3060.     __dt2jlutl := -1;
  3061.     if ((year < 1900) and (year > 99)) then exit;
  3062.     if (year < 100) then inc(year,1900);
  3063.     if ((month < 1) or (month > 12)) then exit;
  3064.     if (((month = 2) and (day = 29)) and ((year mod 4) <> 0)) then exit;
  3065.     if ((day = 0) or (day > days[month])) then exit;
  3066.     if ((year = 1900) and (month < 3)) then exit;
  3067.     dec(year,1900);
  3068.     if (month > 2) then dec(month,3) else begin inc(month,9); dec(year) end;
  3069.     __dt2jlutl := (
  3070.       ((longint(1461) * longint(year)) div 4) +
  3071.       ((153 * month + 2) div 5) + day - 1
  3072.     );
  3073.   end;
  3074.  
  3075.  
  3076.   function __daysutl(yr1, mn1, day1 : word; yr2, mn2, day2 : word) : longint;
  3077.   var temp1, temp2 : longint;
  3078.   begin
  3079.     temp1 := __dt2jlutl(yr1,mn1,day1); temp2 := __dt2jlutl(yr2,mn2,day2);
  3080.     if (temp1 < 0) or (temp2 < 0) then __daysutl := -1 else
  3081.       __daysutl := temp2 - temp1;
  3082.   end;
  3083.   {
  3084.     gordon king in dr.dobbsjournal (number 80, june 1983)
  3085.     and originally published in the collected algorithms
  3086.     of the acm by r.g. tantzen in 1963. 
  3087.   }
  3088.  
  3089.  
  3090.   function  __dbdate: string;
  3091.   var
  3092.     year, month, day,
  3093.     hour, minute, second, tic :   word;
  3094.     s, s1                     : string;
  3095.  
  3096.   begin
  3097.     s := __datestr(year, month, day);
  3098.     s := __timestr(hour, minute, second, tic);
  3099.     s := __dt2ststr(year, month, day, _usa_dt_str);
  3100.     if length(s1)<8 then s := '0' + s;
  3101.     s1 := __time2str(hour, minute, second, tic, 0);
  3102.     if length(s1)<5 then s1 := '0' + s1;
  3103.     __dbdate := s + ' ' + s1 + '  ';
  3104.   end; { __dbdate }
  3105.  
  3106.  
  3107.   function  __radate: string;
  3108.   var
  3109.     year, month, day,
  3110.     hour, minute, second, tic :   word;
  3111.     s, s1                     : string;
  3112.  
  3113.   begin
  3114.     s := __datestr(year, month, day);
  3115.     s := __timestr(hour, minute, second, tic);
  3116.     s := __dt2ststr(year, month, day, _mont_dt_str);
  3117.     s1 := __time2str(hour, minute, second, tic, _inc_sec_str);
  3118.     if length(s1)<8 then s1 := '0' + s1;
  3119.     __radate := '> ' + s1 + '  ';
  3120.   end; { __radate }
  3121.  
  3122.  
  3123.   function  __curdate: string;
  3124.   var
  3125.     year, month, day,
  3126.     hour, minute, second, tic :   word;
  3127.     s, s1                     : string;
  3128.  
  3129.   begin
  3130.     s := __datestr(year, month, day);
  3131.     s := __timestr(hour, minute, second, tic);
  3132.     s := __dt2ststr(year, month, day, _mont_dt_str);
  3133.     s1 := __time2str(hour, minute, second, tic, _inc_sec_str);
  3134.     if length(s1)<8 then s1 := '0' + s1;
  3135.     __curdate := s + '  ' + s1;
  3136.   end; { __curdate }
  3137.  
  3138.  
  3139.   function  __curdate2longint: longint;
  3140.   var
  3141.     year1, mon1,
  3142.     day1, hour1, 
  3143.     min1, sec1,
  3144.     tic1              :     word;
  3145.     s, s1             :   string;
  3146.     datetimepack      : datetime;
  3147.     templong          :  longint;
  3148.  
  3149.   begin
  3150.     s := __datestr(year1, mon1, day1);
  3151.     s := __timestr(hour1, min1, sec1, tic1);
  3152.     with datetimepack do begin
  3153.       year := year1; month := mon1; day := day1;
  3154.       hour := hour1; min := min1; sec := sec1;
  3155.     end; packtime(datetimepack, templong);
  3156.     __curdate2longint := templong;
  3157.   end; { __curdate }
  3158.  
  3159.  
  3160.   function __longint2date(l: longint): string;
  3161.   var dt: datetime;
  3162.   begin
  3163.     unpacktime(l, dt); if dt.year<100 then inc(dt.year, 1900);
  3164.     __longint2date := __juststr(
  3165.       __num(dt.day), '0', 2, _right_just_str
  3166.     ) + ' ' + copy(_strmonths[dt.month], 1, 3) + ' ' +
  3167.       __juststr(__num(dt.year), '0', 2, _right_just_str) + '  ' +
  3168.       __juststr(__num(dt.hour), '0', 2, _right_just_str) + ':' +
  3169.       __juststr(__num(dt.min), '0', 2, _right_just_str) + '.' +
  3170.       __juststr(__num(dt.sec), '0', 2, _right_just_str);
  3171.   end;
  3172.  
  3173.  
  3174.   function __date2longint(d: string): longint;
  3175.   const mons: string[12] = 'JFMAMJJASOND';
  3176.   var                                           {     'xx NNN yy  HH:MM.ss' }
  3177.     st :   string;                              { eg. '22 Aug 69  14:50.11' }
  3178.     dt : datetime;
  3179.     c  :     char;
  3180.     m  :     word;
  3181.     l  :  longint;
  3182.  
  3183.   begin
  3184.     with dt do begin
  3185.       hour := __str(copy(d, 12, 2));
  3186.       min  := __str(copy(d, 15, 2));
  3187.       sec  := __str(copy(d, 18, 2));
  3188.       day  := __str(copy(d, 01, 2));
  3189.       year := __str(copy(d, 08, 2)) + 1900;
  3190.       st := copy(d, 4, 3);
  3191.       c := upcase(d[4]);
  3192.       case c of
  3193.         'A': if st='Apr' then m := 4 else m := 8;
  3194.         'D', 'F', 'N', 'O', 'S': m := pos(c, mons);
  3195.         'J': if st='Jan' then m := 1 else if st='Jun' then m := 6 else m := 7;
  3196.         'M': if st='Mar' then m := 3 else m := 5;
  3197.       end;
  3198.       month := m;
  3199.     end;
  3200.     packtime(dt, l); __date2longint := l;
  3201.   end;
  3202.  
  3203.  
  3204.   (*
  3205.    Format number
  3206.    1 - Xpress method of display last usage date           Mmm DD,YYYY HH:MM:SSap
  3207.    2 - opus display method for date written in messages   Mmm-DD-YY H:MMap
  3208.    3 - Xpress Sysop menu display of last usage.           MM/DD/YY HH:MMap
  3209.    4 - used for opus log                                  DD Mmm HH:MM:SS
  3210.    5 - used for last usage date in user.bbs (opus)        DD Mmm YY HH:MM:SS
  3211.    6 -                                                    Mmm DD, YY
  3212.    7 - used for new files lister in OPUS 1.70             MM/DD/YY
  3213.  
  3214.   *)
  3215.  
  3216.  
  3217.   function format_date(dt:datetime;format : byte):string;
  3218.   var
  3219.     ms, ds, hs,
  3220.     m1s, ss, mhs,
  3221.     ampm          : string[2];
  3222.     ys            : string[4];
  3223.  
  3224.   begin
  3225.     ampm := 'am';
  3226.     with dt do begin
  3227.       str(month:2,ms);
  3228.       str(day:1,ds);
  3229.       str(year:1,ys);
  3230.       str(hour:1,mhs);
  3231.       if format = 4 then if length(mhs)=1 then mhs := '0'+mhs;
  3232.       if format in [3,4,7] then if length(ds)=1  then ds := '0'+ds;
  3233.       if format in [2,5] then ys := copy(ys,3,2);
  3234.  
  3235.       if hour >= 12 then begin
  3236.         ampm := 'pm';
  3237.         if hour > 12 then hour := hour - 12;
  3238.       end;
  3239.       str(hour:1,hs); str(min:2,m1s); str(sec:2,ss);
  3240.       if (format=3) or (format=7) then if hour < 10 then hs := ' '+hs;
  3241.       if m1s[1] = ' ' then m1s[1] := '0';
  3242.       if ss[1] = ' '  then ss[1] := '0';
  3243.       if ms[1] = ' '  then ms[1] := '0';
  3244.       if not (month in [1..12]) then month := 13;
  3245.       if year < 1988 then month := 13;
  3246.       if year > 2000 then month := 13;
  3247.       if (format < 1) or (format > 7) then format := 1;
  3248.       case format of
  3249.        1 : format_date := _strmonths[month]+' '+ds+','+ys+'  '+hs+':'+m1s+':'+ss+ampm;
  3250.        2 : format_date := _strmonths[month]+'-'+ds+'-'+ys+' '+hs+':'+m1s+ampm;
  3251.        3 : format_date := ms+'/'+ds+'/'+copy(ys,3,2)+' '+hs+':'+m1s+ampm;
  3252.        4 : format_date := ds+ ' '+_strmonths[month]+' '+mhs+':'+m1s+':'+ss;
  3253.        5 : format_date := ds+ ' '+_strmonths[month]+' '+ys+' '+mhs+':'+m1s+':'+ss;
  3254.        6 : format_date := _strmonths[month]+' '+ds+','+ys;
  3255.        7 : format_date := ms+'/'+ds+'/'+copy(ys,3,2);
  3256.       end;
  3257.     end;
  3258.   end;
  3259.  
  3260.  
  3261.   procedure __longint2datetime(d: longint; var dt : datetime);
  3262.   var dtst : record date, time : word end absolute d;
  3263.   begin
  3264.     with dtst do begin
  3265.       dt.year  := (hi(date) shr 1) + 1980;
  3266.       dt.month := (date shr 5) and 15;
  3267.       dt.day   := lo(date) and 31;
  3268.       dt.hour  := hi(time) shr 3;
  3269.       dt.min   := (time shr 5) and 63;
  3270.       dt.sec   := (lo(time) and 31) * 2;
  3271.     end;
  3272.   end;
  3273.  
  3274.  
  3275.   function __formatdate(d : longint; format : byte): string;
  3276.   var
  3277.     dt   : datetime;
  3278.   begin
  3279.     __longint2datetime(d, dt);
  3280.     __formatdate := format_date(dt, format);
  3281.   end;
  3282.  
  3283.  
  3284.   function __retdow(y, m, d: word): word;
  3285.   var oy, om, od, odow : word;
  3286.   begin
  3287.     getdate(oy, om, od, odow); setdate(y, m, d); getdate(y, m, d, odow);
  3288.     setdate(oy, om, od);
  3289.     __retdow := odow;
  3290.   end;
  3291.  
  3292.  
  3293.   function __today: byte;
  3294.   var year, month, day, dow: word;
  3295.   begin
  3296.     getdate(year, month, day, dow);
  3297.     __today := dow;
  3298.   end;
  3299.  
  3300.  
  3301.  
  3302.  
  3303.  
  3304.  
  3305.  
  3306.  
  3307.  
  3308. {$IFNDEF USETURBODOS}
  3309. { IMPORTANT DOS FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  3310.   procedure getdate(var year,month,day,dayofweek : word); external;
  3311.   
  3312.   procedure setdate(year,month,day : word); external;
  3313.   
  3314.   procedure gettime(var hour,minute,second,sec100 : word); external;
  3315.   
  3316.   procedure settime(hour,minute,second,sec100 : word); external;
  3317.   function  diskfree(drive : byte) : longint; external;
  3318.   
  3319.   function  disksize(drive : byte) : longint; external;
  3320.   
  3321.   procedure getfattr(var f;var attr : word); external;
  3322.   
  3323.   procedure setfattr(var f;attr : word); external;
  3324.   
  3325.   procedure getftime(var f;var time : longint); external;
  3326.   
  3327.   procedure setftime(var f; time : longint); external;
  3328.   procedure findfirst(path : pathstr;attr : word;var f : searchrec); external;
  3329.   procedure findnext(var f : searchrec); external;
  3330.   
  3331.   procedure unpacktime(p : longint;var t : datetime); external;
  3332.   
  3333.   procedure packtime(var t : datetime;var p : longint); external;
  3334.   
  3335.   function  fexpand(path : pathstr) : pathstr; external;
  3336.   
  3337.   procedure fsplit(
  3338.     path : pathstr;var dir : dirstr;
  3339.     var name : namestr;var ext : extstr
  3340.   ); external;
  3341. {$ENDIF}
  3342.  
  3343.  
  3344.   {$F+}
  3345.   function  __existfil(pathname: string): boolean;
  3346.   var fileinfo: searchrec; 
  3347.   begin
  3348.     findfirst(__normfil(pathname), anyfile, fileinfo);
  3349.     __existfil := (doserror = 0) and not(
  3350.       ((fileinfo.attr and volumeid) > 0) or
  3351.       ((fileinfo.attr and directory) > 0)
  3352.     )
  3353.   end;
  3354.  
  3355.  
  3356.   function __progname: string;
  3357.   const
  3358.     registered : boolean = false;
  3359.  
  3360.   begin
  3361.     if not registered then begin
  3362.       registeredprogname := __extractname(paramstr(0)); registered := true;
  3363.     end;
  3364.     __progname := registeredprogname;
  3365.   end;
  3366.  
  3367.  
  3368.   procedure __erasefil(filename : pathstr; var errorcode : word);
  3369.   var
  3370.     pathlen : word;
  3371.     reg     : registers;
  3372.  
  3373.   begin
  3374.     pathlen := length(filename);
  3375.     move(filename[1],filename[0],pathlen);
  3376.     filename[pathlen] := #0;
  3377.     with reg do begin
  3378.       ax := $4100; ds := seg(filename); dx := ofs(filename); intr($21, reg);
  3379.       if ((flags and fcarry) <> 0) then errorcode := ax else errorcode := 0
  3380.     end
  3381.   end;
  3382.   {$F-}
  3383.  
  3384.  
  3385. {$IFNDEF USETURBODOS}
  3386.   procedure intr(intno : byte;var regs : registers); external;
  3387.   procedure getintvec(intno: byte;var vector: pointer); external;
  3388.   procedure swapvectors; external;
  3389. {$ENDIF}
  3390.   
  3391.  
  3392.   function  __dosinkey(var extendedcode : byte) : char;
  3393.   var reg : registers;
  3394.   begin
  3395.     with reg do begin
  3396.       ah := $07; intr($21, reg);
  3397.       if (al=0) then begin
  3398.         __dosinkey := chr(0); ah := $07; intr($21,reg)
  3399.       end else __dosinkey := chr(al);
  3400.       extendedcode  := al
  3401.     end
  3402.   end;
  3403.  
  3404.  
  3405.   function  __exrdykey(
  3406.     useextended : boolean;
  3407.     var nextch : char;
  3408.     var scancode : byte
  3409.   ) : boolean;
  3410.   var reg : registers;
  3411.   begin
  3412.     with reg do begin                            
  3413.       flags := 0;
  3414.       if (useextended) then ah := $11 else ah := $01;
  3415.       intr($16, reg);
  3416.       if ((flags and fzero) = 0) then begin                       
  3417.         scancode := ah; nextch := char(al); __exrdykey := true
  3418.       end else __exrdykey := false
  3419.     end
  3420.   end;
  3421.  
  3422.  
  3423.  
  3424.   procedure __flushkey;
  3425.   var reg : registers;
  3426.   begin
  3427.     with reg do begin ax := $0c06; dx := $00ff end; intr($21, reg)
  3428.   end;
  3429.  
  3430.  
  3431.  
  3432.  
  3433.  
  3434.   function __queuekey : word;
  3435.   var
  3436.     bufferhead  : word absolute _biosseg:$001a;
  3437.     buffertail  : word absolute _biosseg:$001c;
  3438.     bufferstart : word absolute _biosseg:$0080;
  3439.     bufferend   : word absolute _biosseg:$0082;
  3440.     avail       :                         word;
  3441.  
  3442.   begin
  3443.     if (bufferhead > buffertail) then avail := (bufferhead - buffertail) else
  3444.       avail := (bufferhead + (bufferend - bufferstart) - buffertail);
  3445.     __queuekey := avail;
  3446.   end;
  3447.  
  3448.  
  3449.  
  3450.  
  3451.   function  keypressed : boolean;
  3452.   begin
  3453.     keypressed := crt.keypressed;
  3454.   end;
  3455.  
  3456.  
  3457.  
  3458.  
  3459.   procedure __delay(w: word);
  3460.   var i : word;
  3461.  
  3462.     procedure wait_100; { 01:57:22.13 }
  3463.     begin
  3464.       starttimer(maxtimer);
  3465.       repeat until(__str(copy(getlaptime(maxtimer), 10, 2)) >= 9);
  3466.       stoptimer(maxtimer);
  3467.     end;
  3468.  
  3469.     procedure wait_250; { 01:57:22.13 }
  3470.     begin
  3471.       starttimer(maxtimer);
  3472.       repeat until(__str(copy(getlaptime(maxtimer), 10, 2)) >= 23);
  3473.       stoptimer(maxtimer);
  3474.     end;
  3475.  
  3476.     procedure wait_1000; { 01:57:22.13 }
  3477.     begin
  3478.       starttimer(maxtimer);
  3479.       repeat until(__str(copy(getlaptime(maxtimer), 7, 2)) >= 1);
  3480.       stoptimer(maxtimer);
  3481.     end;
  3482.  
  3483.   begin
  3484.     if (w < 5000) and (w > 100) then
  3485.       for i := 1 to __main(w, 250) div 250 do wait_250 else
  3486.       if (w < 5000) and (w <= 100) then
  3487.         for i := 1 to __main(w, 100) div 100 do wait_100 else
  3488.         for i := 1 to __main(w, 1000) div 1000 do wait_1000;
  3489.   end;
  3490.  
  3491.  
  3492.  
  3493.  
  3494.   procedure __delaykey(w:word);
  3495.   var
  3496.     i, jj : integer;
  3497.     c    :    char;
  3498.  
  3499.   begin
  3500.     i := 1;
  3501.     while i < (w div 250) do begin
  3502.       __delay(250); inc(i);
  3503.       if keypressed then begin i := maxint; __flushkey end;
  3504.     end;
  3505.   end;
  3506.  
  3507.  
  3508.  
  3509.   function __paridutl(var cmdprocid : word) : word;
  3510.   var cmdptr : pointer;
  3511.   begin 
  3512.     getintvec($2e,cmdptr);
  3513.     cmdprocid := _vectoraddr(cmdptr)._seg;
  3514.     __paridutl := memw[prefixseg:$16]
  3515.   end;  
  3516.  
  3517.  
  3518.  
  3519.   function cmdenvseg(var cmdprocid: word): word;
  3520.   type
  3521.     _memctrl = record                      
  3522.       _header   : char;         
  3523.       _ownerpsp : word;         
  3524.       _size     : word;         
  3525.       _reserved : array[1..11] of byte     
  3526.     end;
  3527.  
  3528.   var
  3529.     memblockptr : ^_memctrl;
  3530.     envseg      : word;
  3531.     parid       : word;
  3532.  
  3533.   begin 
  3534.     parid := __paridutl(cmdprocid); memblockptr := ptr(cmdprocid - 1, 0);
  3535.     repeat
  3536.       __iptrsup(
  3537.         pointer(memblockptr),
  3538.         16 * longint(memblockptr^._size + 1)
  3539.       );
  3540.       envseg := _vectoraddr(memblockptr)._seg + 1
  3541.     until (
  3542.       (memblockptr^._ownerpsp = cmdprocid) or
  3543.       (memblockptr^._header = 'Z')
  3544.     );
  3545.     if (memblockptr^._ownerpsp <> cmdprocid) then envseg := 0;
  3546.     cmdenvseg := envseg
  3547.   end; 
  3548.  
  3549.  
  3550.  
  3551.  
  3552.   function __spaceutl(
  3553.     drive : byte;
  3554.     var availclus, totalclus,
  3555.     bytespersec, secsperclus: word
  3556.   ): longint;
  3557.   var reg : registers;
  3558.   begin
  3559.     with reg do begin
  3560.       ah := $36; dl := drive; intr($21,reg);
  3561.       if (ax = $ffff) then begin
  3562.         availclus := 0; totalclus := 0; bytespersec := 0;
  3563.         secsperclus := 0; __spaceutl  := -1
  3564.       end else begin
  3565.         availclus := bx; totalclus := dx; bytespersec := cx;
  3566.         secsperclus := ax;
  3567.         __spaceutl  := longint(bx) * longint(cx) * longint(ax)
  3568.       end
  3569.     end
  3570.   end;
  3571.  
  3572.  
  3573.  
  3574.   function __putenutl(envstr: string): string;
  3575.   type
  3576.     _memctrl   = record                      
  3577.       _header   : char;         
  3578.       _ownerpsp : word;         
  3579.       _size     : word;         
  3580.       _reserved : array[1..11] of byte
  3581.     end;
  3582.  
  3583.     function retmemblock(
  3584.       request: word; var allocbytes: word; var memoryptr: pointer
  3585.     ): pointer;
  3586.     var tempptr : pointer;
  3587.     begin
  3588.       allocbytes := 16 * (request + 1) + 15;
  3589.       getmem(memoryptr,allocbytes);
  3590.       if (memoryptr = nil) then begin
  3591.         allocbytes := 0; retmemblock := nil; exit
  3592.       end;
  3593.       fillchar(memoryptr^,allocbytes,$40);
  3594.       if (_vectoraddr(memoryptr)._ofs <> 0) then
  3595.         tempptr := ptr(_vectoraddr(memoryptr)._seg + 1,0) else
  3596.         tempptr := memoryptr;
  3597.       with _memctrl(tempptr^) do begin
  3598.         _header   := 'M';
  3599.         _ownerpsp := prefixseg;
  3600.         _size     := request;
  3601.         fillchar(_reserved,11,0)
  3602.       end;
  3603.       retmemblock := tempptr
  3604.     end;
  3605.  
  3606.   var
  3607.     envsize      : word;
  3608.     errorcode    : word;
  3609.     tempptr      : pointer;
  3610.     newenvmemptr : pointer;
  3611.  
  3612.   begin
  3613.     __putenutl := '';
  3614.     if (envmemptr_ = nil) then begin
  3615.       envsize := memw[_envseg - 1:3];
  3616.       tempptr := retmemblock(envsize + 16,envsize_,envmemptr_);
  3617.       if (tempptr = nil) then exit;
  3618.       _envptr := ptr(_vectoraddr(tempptr)._seg + 1,0);
  3619.       move(memw[_envseg:0],_envptr^,16 * envsize);
  3620.       memw[prefixseg:$2c] := _vectoraddr(_envptr)._seg;
  3621.       __putenutl := __chgenutl(prefixseg,envstr,errorcode);
  3622.       if (errorcode <> 0) then __putenutl := ''
  3623.     end else begin
  3624.       __putenutl := __chgenutl(prefixseg,envstr,errorcode);
  3625.       if (errorcode <> 2) then exit; 
  3626.       tempptr := retmemblock((envsize_ div 16) + 15, envsize, newenvmemptr);
  3627.       if (tempptr = nil) then exit;
  3628.       __iptrsup(tempptr,16);
  3629.       move(_envptr^,tempptr^,envsize_-_vectoraddr(envmemptr_)._ofs - 16);
  3630.       memw[prefixseg:$2c] := _vectoraddr(tempptr)._seg;
  3631.       _envptr := tempptr;
  3632.       freemem(envmemptr_,envsize_);
  3633.       envmemptr_ := newenvmemptr;
  3634.       envsize_   := envsize;
  3635.       __putenutl := __chgenutl(prefixseg,envstr,errorcode);
  3636.       if (errorcode <> 0) then __putenutl := ''
  3637.     end
  3638.   end;
  3639.  
  3640.  
  3641.  
  3642.  
  3643.   function __retenutl(var envpos : word) : string;
  3644.   type environmentptr = ^_memorychar;
  3645.   var
  3646.     envptr  : environmentptr;
  3647.     strlen  : integer;
  3648.     i       : integer;
  3649.     tempch  : char;
  3650.     tempstr : string;
  3651.     tempptr : pointer;
  3652.  
  3653.   begin
  3654.     envptr := environmentptr(_envptr);
  3655.     strlen := 0;
  3656.     i      := envpos;
  3657.     tempch := envptr^[i];
  3658.     while (tempch <> #0) do begin
  3659.       inc(strlen);                 
  3660.       tempstr[strlen] := tempch;   
  3661.       inc(i);                      
  3662.       tempch := envptr^[i]         
  3663.     end;
  3664.  
  3665.     tempstr[0] := chr(strlen); 
  3666.     if (strlen <> 0) then envpos  := i + 1;
  3667.     __retenutl := tempstr
  3668.   end;
  3669.  
  3670.  
  3671.  
  3672.   function __chgenutl(progseg: word; envstr: string; var error: word): string;
  3673.   const
  3674.     equal = '=';
  3675.     blank = ' ';
  3676.     tab   = #9;
  3677.  
  3678.   var
  3679.     envseg         : word;
  3680.     cmdprocid      : word;
  3681.     parid          : word;
  3682.     envptr         : ^_memorychar;
  3683.     idstr          : string[127];
  3684.     prevsize       : word;              
  3685.     newsize        : word;              
  3686.     totalsize      : word;
  3687.     varpos,varsize : integer;
  3688.     i,j            : integer;
  3689.     lenenvstr      : integer;
  3690.     equalpos       : integer;
  3691.     eqsign         : integer;
  3692.     eqpos          : integer;
  3693.     found          : boolean;
  3694.     envvar,retstr  : string;
  3695.     tempch         : char;
  3696.     locenvptr      : pointer;
  3697.  
  3698.   begin 
  3699.     __chgenutl := ''; error  := 0;
  3700.     if (progseg = 0) then progseg := prefixseg;           
  3701.     if (memw[progseg - 1:1] <> progseg) then begin
  3702.       error := 1; exit;
  3703.     end;
  3704.     envseg := memw[progseg:$2C];
  3705.     if (envseg = 0) then begin
  3706.       envseg := cmdenvseg(cmdprocid);   
  3707.       if (progseg <> cmdprocid) then begin
  3708.         error := 1; exit;
  3709.       end
  3710.     end else if (memw[envseg - 1 : 1] <> progseg) then begin 
  3711.       error := 1; exit
  3712.     end;
  3713.     locenvptr := _envptr; _envptr := ptr(envseg,0);
  3714.     i := 1; found := true; lenenvstr := length(envstr);
  3715.     while ((i <= lenenvstr) and found) do if (
  3716.       (envstr[i] = blank) or (envstr[i] = tab)
  3717.     ) then inc(i) else found := false;
  3718.     j := i - 1; lenenvstr := lenenvstr - j;        
  3719.     eqsign := 0;
  3720.     for i := 1 to lenenvstr do begin
  3721.       tempch := envstr[i + j];
  3722.       if (tempch = equal) then begin inc(eqsign); eqpos  := i end;
  3723.       if (eqsign <> 0) then envstr[i] := tempch else 
  3724.         envstr[i] := upcase(tempch) 
  3725.     end;
  3726.     if (eqsign <> 1) then begin error := 3; exit end else begin
  3727.       envstr[0]  := chr(lenenvstr);    
  3728.       __chgenutl := envstr             
  3729.     end;
  3730.     envvar := copy(envstr,1,eqpos - 1); varpos := 0; prevsize := 1;                     
  3731.     repeat
  3732.       retstr := __retenutl(prevsize);
  3733.       if (length(retstr) <> 0) then begin
  3734.         if (varpos = 0) then if (
  3735.           envvar = copy(retstr,1,pos(equal,retstr) - 1)
  3736.         ) then begin varsize := length(retstr)+1; varpos := prevsize-varsize end;
  3737.       end;
  3738.     until (length(retstr) = 0);
  3739.     if (length(copy(envstr,eqpos + 1,255)) = 0) then begin                           
  3740.       newsize := prevsize; lenenvstr := 0
  3741.     end else newsize := prevsize + lenenvstr + 1;
  3742.     if (varpos <> 0) then newsize := newsize - varsize;   
  3743.     idstr := ''; j := 0;
  3744.     envptr := ptr(envseg,prevsize);
  3745.     if (word(pointer(envptr)^) = 1) then begin
  3746.       __iptrsup(pointer(envptr),2);
  3747.       repeat
  3748.         inc(j);
  3749.         idstr[j] := envptr^[j]
  3750.       until (idstr[j] = #0)
  3751.     end;
  3752.     idstr[0] := char(j);
  3753.     totalsize := newsize + j;
  3754.     if (totalsize > (memw[envseg - 1:3] * 16)) then begin
  3755.       error := 2; __chgenutl := ''; exit
  3756.     end;
  3757.     envptr := ptr(envseg,0);
  3758.     if (varpos = 0) then move(envstr[1],envptr^[prevsize],lenenvstr) else begin
  3759.       move(
  3760.         envptr^[varpos + varsize],
  3761.         envptr^[varpos],prevsize - varpos - varsize
  3762.       );
  3763.       move(envstr[1],envptr^[prevsize - varsize],lenenvstr);
  3764.     end;
  3765.     envptr^[newsize - 1] := chr(0);
  3766.     envptr^[newsize]     := chr(0);
  3767.     if (length(idstr) > 0) then begin
  3768.       envptr^[newsize + 1] := #1;
  3769.       envptr^[newsize + 2] := #0;
  3770.       move(idstr[1],envptr^[newsize + 3],length(idstr))
  3771.     end;
  3772.     _envptr := locenvptr;               
  3773.   end;  
  3774.  
  3775.  
  3776.  
  3777.   function  __envpath(st: string): string; { ends on \ }
  3778.   var
  3779.     envpos     :   word;
  3780.     tmp, envstr: string;
  3781.  
  3782.   begin
  3783.     envpos := 1; envstr := __retenutl(envpos);
  3784.     while length(envstr) <> 0 do begin
  3785.       if copy(envstr,1, length(st)+1) = (st + '=') then
  3786.         tmp := copy(envstr,length(st)+2,length(envstr)-(length(st)+1));
  3787.       envstr := __retenutl(envpos)
  3788.     end;
  3789.     __envpath := tmp;
  3790.   end; { __envpath }
  3791.  
  3792.  
  3793.  
  3794.   function __getpath(var fname : string) : boolean;
  3795.   { returns the full path and filename for a filename if the file  }
  3796.   { is found in the path. }
  3797.  
  3798.   var
  3799.     found         : boolean;
  3800.     setpath,
  3801.     homedir,
  3802.     extractedpath :  string;
  3803.     i, j, len     :    byte;
  3804.  
  3805.   begin
  3806.     homedir := __normfil(fname);
  3807.     if __existfil(homedir) then begin
  3808.       fname := homedir; __getpath := true; exit;
  3809.     end;
  3810.     setpath := __xlatestr(getenv('PATH'), ';', ' ') + ' ';
  3811.     j := 1; len := length(setpath);
  3812.     repeat
  3813.       inc(j); i := j; 
  3814.       while (setpath[j] <> ' ') and (j < len) do inc(j); inc(j);
  3815.       extractedpath := __backapp(copy(setpath, i-1, j-i));
  3816.       found := __existfil(extractedpath + fname);
  3817.     until (found) or (j > len) or (i > len);
  3818.     if found then fname := extractedpath + fname;
  3819.     __getpath := found;
  3820.   end;
  3821.  
  3822.  
  3823.  
  3824.   function __address(zone, net, node, point: integer): string;
  3825.   begin
  3826.    __address :=
  3827.      __num(zone) + ':' + __num(net) + '/' + __num(node) + '.' + __num(point);
  3828.   end;
  3829.  
  3830.  
  3831.  
  3832.   procedure __expandnum(
  3833.     node : string; var tozone, tonet, tonode, topoint: word
  3834.   );
  3835.   var                      { zzzzz:nnnnn/nnnnn.ppppp }
  3836.     i, j : byte;           { eg.  '12:5003/1222.000' }
  3837.  
  3838.   begin
  3839.     i := pos(':', node);
  3840.     tozone := __str(copy(node, 1, i - 1));
  3841.     j := pos('/', node); if j=0 then j := pos('\', node);
  3842.     tonet  := __str(copy(node, i + 1, j - i - 1));
  3843.     i := pos('.', node);
  3844.     if i > 0 then tonode := __str(copy(node, j+1, i-j-1)) else
  3845.       tonode := __str(copy(node, j+1, length(node)-j));
  3846.     topoint := __str(copy(node, i + 1, length(node) - i));
  3847.   end;
  3848.  
  3849.  
  3850.  
  3851.   function __expandchr(st: string; c: char; chh:  string): string;
  3852.   var
  3853.     lenst,
  3854.     j      : byte;
  3855.  
  3856.   begin
  3857.     j := 1; lenst := length(st);
  3858.     while (j <= lenst) do begin
  3859.       while (j <= lenst) and (st[j] <> c) do inc(j);
  3860.       if (j <= lenst) then begin
  3861.         delete(st, j, 1); 
  3862.         if j < lenst then insert(chh, st, j) else st := st + chh;
  3863.         inc(lenst, length(chh)); inc(j, length(chh));
  3864.       end;
  3865.     end;
  3866.     __expandchr := st;
  3867.   end;
  3868.  
  3869.  
  3870.  
  3871.   function  __ctrlkey(status : _keystatus) : longint;
  3872.   var
  3873.     statusloc  : word absolute _biosseg:$0017;
  3874.     statusloc2 : byte absolute _biosseg:$0096;
  3875.     statusword : word;
  3876.     statusbyte : byte;
  3877.  
  3878.   begin
  3879.     statusword := 0; statusbyte := 0;
  3880.     with status do begin
  3881.       if (_insstate      ) then statusword := statusword or $8000;
  3882.       if (_capsstate     ) then statusword := statusword or $4000;
  3883.       if (_numstate      ) then statusword := statusword or $2000;
  3884.       if (_scrollstate   ) then statusword := statusword or $1000;
  3885.       if (_altshift      ) then statusword := statusword or $0800;
  3886.       if (_ctrlshift     ) then statusword := statusword or $0400;
  3887.       if (_leftshift     ) then statusword := statusword or $0200;
  3888.       if (_rightshift    ) then statusword := statusword or $0100;
  3889.       if (_insshift      ) then statusword := statusword or $0080;
  3890.       if (_capsshift     ) then statusword := statusword or $0040;
  3891.       if (_numshift      ) then statusword := statusword or $0020;
  3892.       if (_scrollshift   ) then statusword := statusword or $0010;
  3893.       if (_holdstate     ) then statusword := statusword or $0008;
  3894.       if (_sysshift      ) then statusword := statusword or $0004;
  3895.       if (_rightctrlshift) then statusbyte := statusbyte or $0008;
  3896.       if (_rightaltshift ) then statusbyte := statusbyte or $0004;
  3897.       if (_leftctrlshift ) then statusword := statusword or $0002;
  3898.       if (_leftaltshift  ) then statusword := statusword or $0001
  3899.     end;
  3900.     statusloc  := swap(statusword);
  3901.     statusloc2 := statusloc2 or statusbyte;
  3902.     __ctrlkey  := longint(statusword) or (longint(statusbyte) shl 16)
  3903.   end;
  3904.  
  3905.  
  3906.   function  __statkey(var status : _keystatus) : longint;
  3907.   var
  3908.     statusloc  : word absolute _biosseg:$0017;
  3909.     statusloc2 : byte absolute _biosseg:$0096;
  3910.     statusword : word;
  3911.     statusbyte : byte;
  3912.  
  3913.   begin
  3914.     statusword := swap(statusloc);          { 8086 stores "backwords"   }
  3915.     statusbyte := (statusloc2 shr 2) and 3; { flags in 2 low order bits }
  3916.     with status do begin
  3917.       _insstate       := ((statusword and $8000) <> 0);
  3918.       _capsstate      := ((statusword and $4000) <> 0);
  3919.       _numstate       := ((statusword and $2000) <> 0);
  3920.       _scrollstate    := ((statusword and $1000) <> 0);
  3921.       _altshift       := ((statusword and $0800) <> 0);
  3922.       _ctrlshift      := ((statusword and $0400) <> 0);
  3923.       _leftshift      := ((statusword and $0200) <> 0);
  3924.       _rightshift     := ((statusword and $0100) <> 0);
  3925.       _insshift       := ((statusword and $0080) <> 0);
  3926.       _capsshift      := ((statusword and $0040) <> 0);
  3927.       _numshift       := ((statusword and $0020) <> 0);
  3928.       _scrollshift    := ((statusword and $0010) <> 0);
  3929.       _holdstate      := ((statusword and $0008) <> 0);
  3930.       _sysshift       := ((statusword and $0004) <> 0);
  3931.       _leftaltshift   := ((statusword and $0002) <> 0);
  3932.       _leftctrlshift  := ((statusword and $0001) <> 0);
  3933.       _rightctrlshift := ((statusbyte and $01) <> 0);
  3934.       _rightaltshift  := ((statusbyte and $02) <> 0)
  3935.     end;
  3936.     __statkey := (longint(statusbyte) shl 16) or longint(statusword)
  3937.   end;
  3938.  
  3939.  
  3940.  
  3941.   function  __stuffkey;
  3942.   type
  3943.     _keyseq = record _ch : char; _scancode :  byte end;
  3944.  
  3945.     function placekey(keystroke : _keyseq) : boolean;
  3946.     var
  3947.       nextpos     : word;
  3948.       bufferptr   : ^word;
  3949.       bufferhead  : word absolute _biosseg:$001a;
  3950.       buffertail  : word absolute _biosseg:$001c;
  3951.       bufferstart : word absolute _biosseg:$0080;
  3952.       bufferend   : word absolute _biosseg:$0082;
  3953.  
  3954.     begin
  3955.       nextpos := buffertail + 2;                { we have wrap around   }
  3956.       if (nextpos >= bufferend) then nextpos  := bufferstart;   
  3957.                                                 { the buffer is full.   }
  3958.       if (nextpos = bufferhead) then placekey := false else begin
  3959.         { put the sequence in right here. }
  3960.         bufferptr := ptr(_biosseg,buffertail);
  3961.         inline($fa);                            { disable interrupts    }
  3962.         bufferptr^ := word(keystroke);
  3963.         buffertail := nextpos;
  3964.         inline($fb);                            { enable interrupts     }
  3965.         placekey := true;
  3966.       end;
  3967.     end;
  3968.  
  3969.   var
  3970.     i,j       : integer;
  3971.     lenstr    : integer;
  3972.     keystroke : _keyseq;
  3973.     stuffed   : boolean;
  3974.  
  3975.   begin
  3976.     lenstr := length(charstr);
  3977.     if (lenstr = 0) then begin         { not much to do, so return       }
  3978.       __stuffkey := charstr;
  3979.       exit
  3980.     end;
  3981.  
  3982.     i := 0;                            { can assume charstr is not empty }
  3983.     repeat
  3984.       inc(i);
  3985.       j := i;                          { save character position in      }
  3986.                { case it cannot be stuffed.     }
  3987.       with keystroke do begin
  3988.         _ch := charstr[i]; _scancode := 0
  3989.       end;
  3990.       stuffed := placekey(keystroke)
  3991.     until ((i = lenstr) or (not stuffed));
  3992.  
  3993.     if (not stuffed) then __stuffkey := copy(charstr,j,lenstr) else
  3994.       __stuffkey := ''
  3995.   end;
  3996.  
  3997.  
  3998.  
  3999.  
  4000.   procedure __resetsup(testmem : boolean);
  4001.   var
  4002.     reset_flag : word absolute $40:$72;
  4003.     ch         : char;
  4004.   
  4005.   begin
  4006.     if testmem then reset_flag := $0000 else reset_flag := $1234;
  4007.     inline($ea/$00/$00/$ff/$ff)        { jmp ffff:0000                  }
  4008.   end;
  4009.  
  4010.  
  4011.  
  4012.  
  4013.   procedure __resetfil;
  4014.   var reg : registers;
  4015.   begin 
  4016.     with reg do begin
  4017.       ah := $0d;
  4018.       intr($21, reg)
  4019.     end;
  4020.   end;
  4021.  
  4022.  
  4023.   function fopen; {open untyped file return the dos error code}
  4024.   var fm : byte;
  4025.   begin
  4026.     assign(fv,fn);
  4027.     fm := filemode;
  4028.     if mode <> _keep_mode then filemode := mode;
  4029.     reset(fv,1);
  4030.     fopen := ioresult;
  4031.     filemode := fm;
  4032.   end;
  4033.  
  4034.  
  4035.  
  4036.  
  4037.   function  fclose(var fv : stream) : integer;
  4038.   begin
  4039.     close(fv);
  4040.     fclose := ioresult;
  4041.   end;
  4042.  
  4043.  
  4044.  
  4045.  
  4046.   function shareloaded : boolean;
  4047.   var reg : registers;
  4048.   begin
  4049.     reg.ax := $1000;
  4050.     intr($2f,reg);
  4051.     shareloaded := ((reg.flags and $01) = 0) and (reg.al = $ff);
  4052.   end;
  4053.  
  4054.  
  4055.   {
  4056.     Lock or Unlock region of file.
  4057.     Input         : Handle  - turbo untype file variable handle (filerec(fv).handle)
  4058.     input         : action  - action to take. See constants above;
  4059.     input         : start   - beginging file position to lock.
  4060.     input         : bytes   - number of bytes to lock.
  4061.     output        : ax      - ax register return value
  4062.     returns TRUE if lock is successful, False otherwise (check AX)
  4063.   }
  4064.  
  4065.  
  4066.   function filelock(handle : word; action : byte; start,bytes : longint; var ax : integer): boolean;
  4067.   var reg : registers;
  4068.   begin
  4069.     reg.ax := $5c00 + action;
  4070.     reg.bx := handle;
  4071.     reg.cx := hi(start);
  4072.     reg.dx := lo(start);
  4073.     reg.si := hi(bytes);
  4074.     reg.di := lo(bytes);
  4075.     intr($21,reg);
  4076.     filelock := (reg.flags and $01) = $00;
  4077.     ax := reg.ax;
  4078.    end;
  4079.  
  4080.  
  4081.  
  4082.  
  4083.   function __exinkey(useextended: boolean; var scancode: byte): char;
  4084.   var reg : registers;
  4085.   begin
  4086.     with reg do begin                       
  4087.       if (useextended) then ah := $10 else ah := 0;
  4088.       al := 0; intr($16, reg); scancode  := ah;
  4089.             __exinkey := char(al)
  4090.     end
  4091.   end;
  4092.  
  4093.  
  4094.   function __retkey: word;
  4095.   var
  4096.     ch: char;
  4097.     sc: byte;
  4098.          
  4099.   begin
  4100.     ch := __exinkey(true, sc);
  4101.     lastkey := ch; lastscan := sc;
  4102.     __retkey := __2wordsup(sc, ord(ch))
  4103.   end;
  4104.  
  4105.  
  4106.  
  4107.   function  __retdelaykey(delaytim: byte; default: word): word;  { delay < 60 }
  4108.   var
  4109.     ch: char;
  4110.     sc: byte;
  4111.          
  4112.   begin
  4113.     ch := #00;
  4114.     if delaytim = 0 then __retdelaykey := __retkey else begin
  4115.       starttimer(2);
  4116.       repeat __exrdykey(true, ch, sc) until (
  4117.         (delaytim > 0) and (__str(copy(getlaptime(2), 7, 2)) >= delaytim)
  4118.       ) or (ch <> #00);
  4119.       if ch = #00 then begin { timeout occurred }
  4120.         if default > 0 then __retdelaykey := default else __retdelaykey := 0;
  4121.       end else begin
  4122.         lastkey := ch; lastscan := sc;
  4123.         __retdelaykey := __2wordsup(sc, ord(ch)); __flushkey
  4124.       end;
  4125.     end;
  4126.   end;
  4127.  
  4128.  
  4129.  
  4130.   function __attrfilter(fileattr, filter: byte): boolean;
  4131.   { 
  4132.     only and notnone may only be used in conjunction with other attribs like
  4133.     readonly, hidden, sysfile, volumeid, directory and archive.
  4134.   }
  4135.   type
  4136.     filterenum = (r_o, hid, sys, vol, dir, arc, only, notnone);
  4137.     filterenumset = set of filterenum;
  4138.  
  4139.   var
  4140.     makefilter : filterenumset;
  4141.     filefilter : filterenumset;
  4142.  
  4143.   begin
  4144.     makefilter := filterenumset(filter);
  4145.     filefilter := filterenumset(fileattr);
  4146.     if (
  4147.       (notnone in makefilter) and ((filefilter - [notnone]) = [])
  4148.     ) then __attrfilter := false else if only in makefilter then
  4149.       __attrfilter := (filefilter + [only] = makefilter) else
  4150.         __attrfilter := (filefilter <= makefilter);
  4151.   end; { __attrfilter }
  4152.  
  4153.  
  4154.  
  4155.   function  __bak(s: string): string;
  4156.   var
  4157.     st : string;
  4158.     i  :   byte;
  4159.  
  4160.   begin
  4161.     st := __extractname(s);
  4162.     if pos('.', st) = 0 then __bak := st + '.BAK' else begin
  4163.       i := length(s);
  4164.       while (i > 0) and (s[i] <> '.') do dec(i);
  4165.       __bak := copy(st, 1, i) + 'BAK';
  4166.     end;
  4167.   end;
  4168.  
  4169.  
  4170.   function  __comexebatcmdfilter;
  4171.   begin
  4172.     __comexebatcmdfilter := (
  4173.       __comp(__extractext(s), 'EXE') or __comp(__extractext(s), 'CMD') or
  4174.       __comp(__extractext(s), 'COM') or __comp(__extractext(s), 'BAT')
  4175.     );
  4176.   end;
  4177.  
  4178.  
  4179.  
  4180.   function __retdrfil : char;
  4181.   var reg : registers;
  4182.   begin  
  4183.     with reg do begin
  4184.       ah := $19; intr($21, reg);
  4185.       __retdrfil := char(byte('A') + al)
  4186.     end
  4187.   end;  
  4188.  
  4189.  
  4190.   function  __curdir: string;
  4191.   var s: string;
  4192.  
  4193.   begin
  4194.     getdir(0, s); __curdir := s;
  4195.   end;
  4196.  
  4197.  
  4198.  
  4199.   function __deverr: string;
  4200.   begin
  4201.     case doserror of
  4202.       000: __deverr := 'No DosError Detected!';
  4203.       002: __deverr := 'File not found';
  4204.       003: __deverr := 'Path not found';
  4205.       004: __deverr := 'Too many open files';
  4206.       005: __deverr := 'File acces denied';
  4207.       006: __deverr := 'Invalid file handle';
  4208.       012: __deverr := 'Invalid file access code';
  4209.       015: __deverr := 'Invalid drive number';
  4210.       016: __deverr := 'Cannot remove current directory';
  4211.       017: __deverr := 'Cannot rename across drives';
  4212.       018: __deverr := 'No more files found';
  4213.       100: __deverr := 'Disk read error';
  4214.       101: __deverr := 'Disk write error';
  4215.       102: __deverr := 'File not assigned';
  4216.       103: __deverr := 'File not open';
  4217.       104: __deverr := 'File not open for input';
  4218.       105: __deverr := 'File not open for output';
  4219.       106: __deverr := 'Invalid numeric format';
  4220.       150: __deverr := 'Disk is write protected';
  4221.       151: __deverr := 'Unknown unit';
  4222.       152: __deverr := 'Drive not ready';
  4223.       153: __deverr := 'Unknown command';
  4224.       154: __deverr := 'CRC error in data';
  4225.       155: __deverr := 'Bad drive request structure length';
  4226.       156: __deverr := 'Disk seek error';
  4227.       157: __deverr := 'Unknown media type';
  4228.       158: __deverr := 'Sector not found';
  4229.       159: __deverr := 'Printer out of paper';
  4230.       160: __deverr := 'Device write fault';
  4231.       161: __deverr := 'Device read fault';
  4232.       162: __deverr := 'Hardware failure'
  4233.       else __deverr := 'Unrecognised Drive Error . . .'
  4234.     end; { of case }
  4235.   end;
  4236.  
  4237.  
  4238.   procedure __drvparm(drv: char);
  4239.   var
  4240.     regs  : registers;
  4241.     error :      word;
  4242.  
  4243.   begin
  4244.     if drv = ' ' then begin
  4245.       regs.ah := $19; 
  4246.       intr($21, regs);
  4247.       _dosdrv := regs.al; inc(_dosdrv);          { dos drive 0 = a         }
  4248.       _dosdrvchar := chr(_dosdrv + 64);          { turbo counts from 1 = a }
  4249.     end else _dosdrv := ord(upcase(drv)) - 64;   { 65 = ascii(upcase(a))   }
  4250.     _dosdiscfree := diskfree(_dosdrv);
  4251.     _dosdiscsize := disksize(_dosdrv);
  4252.     getdir(_dosdrv, _doscurpath)
  4253.   end;
  4254.  
  4255.  
  4256. (*
  4257.   function  __envpath(st: string): string; { ends on \ }
  4258.   var
  4259.     envpos      :   word;
  4260.     tmp, envstr : string;
  4261.  
  4262.   begin
  4263.     envpos := 1; envstr := __retenutl(envpos);
  4264.     while length(envstr) <> 0 do begin
  4265.       if copy(envstr,1, length(st)+1) = (st + '=') then
  4266.         tmp := copy(envstr,length(st)+2,length(envstr)-(length(st)+1));
  4267.       envstr := __retenutl(envpos)
  4268.     end;
  4269.     if tmp[length(tmp)] <> '\' then tmp := tmp + '\';
  4270.     if tmp[length(tmp)] = ' ' then tmp := copy(tmp, 1, length(tmp)-1);
  4271.     __envpath := tmp;
  4272.   end; { __envpath }
  4273. *)
  4274.  
  4275.  
  4276.  
  4277.   procedure __erasefiles(s: string);
  4278.   var
  4279.     error :   word;
  4280.     st    : string;
  4281.  
  4282.   begin
  4283.     while __findfil(s, st) do __erasefil(st, error);
  4284.   end;
  4285.  
  4286.  
  4287.  
  4288. {$I+}
  4289.   function  __existpath(s: string): boolean; { no trailing \ please }
  4290.   var atri : searchrec;
  4291.   begin
  4292.     if s[length(s)]=_dirslash then findfirst(
  4293.       __normfil(s + '*.*'), anyfile, atri
  4294.     ) else findfirst(
  4295.       __normfil(s + '\*.*'), anyfile, atri
  4296.     );
  4297.     __existpath := (doserror=0)
  4298.   end;
  4299. {$I-}
  4300.  
  4301.  
  4302.  
  4303.  
  4304.   function  __extractext;
  4305.   var p: byte;
  4306.   begin
  4307.     p := length(name);
  4308.     while (not(name[p] = _dirslash)) and (p > 0) do dec(p);
  4309.     while (name[p] <> '.') and (p < length(name)) do inc(p);
  4310.     { . or not }
  4311.     if (name[p] <> '.') and (__lastchr(name) <> '.') then 
  4312.       __extractext := '' else
  4313.       __extractext := copy(name, p+1, length(name) - p);
  4314.   end;
  4315.  
  4316.  
  4317.  
  4318.   function __extractname(s : string): string;
  4319.   var
  4320.     i, j : byte;
  4321.  
  4322.   begin
  4323.     i := length(s);
  4324.     if pos('.', s) > 0 then while (s[i] <> '.') and (i > 0) do dec(i);
  4325.     j := i;
  4326.     while (s[j] <> _dirslash) and (j > 0) do dec(j);
  4327.     __extractname := copy(s, j+1, i-j-1);
  4328.   end;
  4329.  
  4330.  
  4331.  
  4332.   function __extractnamext(s : string): string;
  4333.   var
  4334.     i, j : byte;
  4335.  
  4336.   begin
  4337.     i := length(s); j := i;
  4338.     if pos(_dirslash, s) > 0 then while (s[j] <> _dirslash) and (j > 0) do dec(j);
  4339.     __extractnamext := copy(s, j+1, i-j);
  4340.   end;
  4341.  
  4342.  
  4343.  
  4344.   function __extractpath(s : string): string; { eindigt op \ }
  4345.   var
  4346.     i : byte;
  4347.  
  4348.   begin
  4349.     i := length(s); while (s[i] <> _dirslash) and (i > 1) do dec(i);
  4350.     __extractpath := copy(s, 1, i);
  4351.   end;
  4352.  
  4353.  
  4354.  
  4355.  
  4356.  
  4357.   function  __findfil(f: string; var s: string): boolean;
  4358.   var
  4359.     r    : searchrec;
  4360.     l    :    string;
  4361.     j, e :      byte;
  4362.  
  4363.   begin
  4364.     fillchar(r, sizeof(r), #0); findfirst(__normfil(f), $3f, r); e := doserror;
  4365.     if ((r.attr and directory)>0) or ((r.attr and volumeid)>0) then e := 0;
  4366.     j := length(f);
  4367.     if pos(_dirslash, f) > 0 then while f[j] <> _dirslash do dec(j);
  4368.     if e = 0 then s := copy(f, 1, j) + r.name else s := __num(e);
  4369.     if e = 0 then __findfil := true else __findfil := false;
  4370.   end;
  4371.  
  4372.  
  4373.  
  4374.   function  __inparams(s: string; var i: word): boolean;
  4375.   var
  4376.     j :    byte;
  4377.     t :  string;
  4378.     b : boolean;
  4379.  
  4380.   begin
  4381.     b := false;
  4382.     if casesensitive_env then s := __up(s);
  4383.     for j := 1 to paramcount do begin
  4384.       if casesensitive_env then t := __up(paramstr(j)) else t := paramstr(j);
  4385.       if __comp(s, t) then begin i := j + 1; b := true end;
  4386.     end;
  4387.     __inparams := b;
  4388.   end;
  4389.  
  4390.  
  4391.  
  4392.   function __checkstr(pa, en: string; var j, k : word): boolean;
  4393.   begin
  4394.     j := pos(__up(pa), __up(en));
  4395.     __checkstr := (j > 0) and (length(pa) > 0) and (length(en) > 0);
  4396.     if j > 0 then begin
  4397.       inc(j, length(pa)); while (en[j] = ' ') and (j <= length(en)) do inc(j);
  4398.     end;
  4399.     k := j; while (en[k] <> ' ') and (k <= length(en)) do inc(k);
  4400.     {
  4401.       j..k is parameter after switch "pa" in "en"
  4402.       e.g. PROG /x 12 /u 2
  4403.                 1234567890
  4404.         __checkstr('/x', '/x 12 /u 2', j, k);
  4405.         j = 4
  4406.         k = 5
  4407.     }
  4408.   end;
  4409.  
  4410.  
  4411.  
  4412.   function  __packfil(str: string; size: byte): string;
  4413.   var i,ii: byte;
  4414.   begin
  4415.     if size < 15 then size := 15;
  4416.     str := __xlatestr(__backrem(__normfil(str)), '\', _dirslash);
  4417.     if length(str) <= size then __packfil := str else begin
  4418.       while length(str) > size+1 do begin
  4419.         i := pos(_dirslash,str); inc(i); ii := i; 
  4420.         while str[ii] <> _dirslash do inc(ii);
  4421.         inc(ii); delete(str,i,ii-i);
  4422.       end; i := pos(_dirslash,str); delete(str,i,1); 
  4423.       __packfil := str
  4424.     end;
  4425.   end;
  4426.  
  4427.  
  4428.  
  4429.  
  4430.   procedure __parsefil(name: filestr; var nam: namestr; var ext: extstr);
  4431.   var p: byte;
  4432.   begin
  4433.     p := pos('.', name); fillchar(nam, 8, ' '); fillchar(ext, 3, ' ');
  4434.     if p = 0 then begin
  4435.       nam := name; ext := '   '
  4436.     end else begin
  4437.       nam := copy(name, 1, p-1);
  4438.       ext := copy(name, p+1, length(name)-p);
  4439.     end;
  4440.   end;
  4441.  
  4442.  
  4443.   function __slashfil;
  4444.   begin
  4445.     s := __xlatestr(s, '/\', _dirslash+_dirslash);
  4446.     __slashfil := s;
  4447.   end;
  4448.  
  4449.  
  4450.   function __normfil(filename : pathstr) : pathstr;
  4451.   const
  4452.     colon   = ':';
  4453.     fslash  = '/';
  4454.     bslash  = '\';
  4455.  
  4456.  
  4457.     procedure getnextdir(
  4458.       filename : pathstr;
  4459.       getdrive : boolean;
  4460.       var startpos : byte;
  4461.       var rettoken : pathstr
  4462.     );
  4463.     var
  4464.       len      : byte;
  4465.       curdrive : char;
  4466.       curdir   : string;
  4467.  
  4468.     begin
  4469.       rettoken := '';
  4470.       if (getdrive) then begin
  4471.         startpos := 1;
  4472.         if ((length(filename) > 1) and (filename[2] = colon)) then begin
  4473.           curdrive := upcase(filename[1]); inc(startpos,2)
  4474.         end else curdrive := __retdrfil;
  4475.         rettoken := curdrive + ':\';
  4476.         if (
  4477.           (startpos > length(filename)) or
  4478.           (
  4479.             (filename[startpos] <> fslash) and
  4480.             (filename[startpos] <> bslash)
  4481.           )
  4482.         ) then begin
  4483.           getdir(byte(curdrive) - 64,curdir);
  4484.           if (ioresult = 0) then rettoken := curdir
  4485.         end
  4486.       end else begin
  4487.         if (startpos > length(filename)) then exit;
  4488.         if (
  4489.           (filename[startpos] = fslash) or
  4490.           (filename[startpos] = bslash)
  4491.         ) then begin
  4492.           len := 1; rettoken[1] := bslash; inc(startpos)
  4493.         end else len := 0;
  4494.         while (
  4495.           (startpos <= length(filename)) and
  4496.           (filename[startpos] <> fslash) and
  4497.           (filename[startpos] <> bslash)
  4498.         ) do begin
  4499.           inc(len);
  4500.           rettoken[len] := upcase(filename[startpos]);
  4501.           inc(startpos)
  4502.         end;
  4503.         rettoken[0] := char(len)
  4504.       end
  4505.     end;   { subproc }
  4506.  
  4507.  
  4508.     procedure putnextdir(
  4509.       token: pathstr;
  4510.       var lastdirpos : byte;
  4511.       var normfile : pathstr
  4512.     );
  4513.     var len : byte;
  4514.     begin
  4515.       if (
  4516.         (token = '.') or (token = '\.') or (length(token) = 0)
  4517.       ) then exit else if ((token = '..') or (token = '\..')) then begin
  4518.         if (lastdirpos > 0) then begin
  4519.           if (lastdirpos = 3) then normfile[0] := char(lastdirpos);
  4520.           dec(lastdirpos);
  4521.           if (lastdirpos > 2) then normfile[0] := char(lastdirpos);
  4522.           while (
  4523.             (lastdirpos >= 1) and
  4524.             (normfile[lastdirpos] <> bslash)
  4525.           ) do dec(lastdirpos)
  4526.         end
  4527.       end else begin
  4528.         len := length(normfile);
  4529.         if ((normfile[len] = bslash) and (token[1] = bslash)) then begin
  4530.           dec(len);
  4531.           normfile[0] := char(len)
  4532.         end else if (
  4533.           (normfile[len] <> bslash) and
  4534.           (token[1] <> bslash)
  4535.         ) then normfile := normfile + bslash;
  4536.         lastdirpos := length(normfile) + 1;
  4537.         normfile   := normfile + token
  4538.       end
  4539.     end;
  4540.  
  4541.  
  4542.   var
  4543.     nextsubdir : byte;
  4544.     lastsubdir : byte;
  4545.     subdir     : pathstr;
  4546.     normalfile : pathstr;
  4547.  
  4548.  
  4549.  
  4550.   begin
  4551.     nextsubdir := 0;
  4552.     getnextdir(filename,true,nextsubdir,normalfile);
  4553.     lastsubdir := length(normalfile) - 1;
  4554.     while (
  4555.       (lastsubdir >= 1) and (normalfile[lastsubdir] <> bslash)
  4556.     ) do dec(lastsubdir);
  4557.     while (nextsubdir <= length(filename)) do begin
  4558.       getnextdir(filename,false,nextsubdir,subdir);
  4559.       putnextdir(subdir,lastsubdir,normalfile);
  4560.     end;
  4561.     __normfil := normalfile
  4562.   end;
  4563.  
  4564.  
  4565.  
  4566.  
  4567.   procedure __splitfil(
  4568.     pathname     :  pathstr;
  4569.     var subdir   :   dirstr;
  4570.     var filename :  namestr;
  4571.     var fileext  :   extstr
  4572.   );
  4573.  
  4574.   const
  4575.     colon   = ':';
  4576.     fslash  = '/';
  4577.     bslash  = '\';
  4578.     period  = '.';
  4579.  
  4580.   var
  4581.     i        : byte;
  4582.     len      : byte;
  4583.     found    : boolean;
  4584.     extpos   : byte;
  4585.     dirpos   : byte;
  4586.     filelen  : byte;
  4587.     thischar : char;
  4588.  
  4589.   begin
  4590.     subdir := ''; filename := ''; fileext := ''; len := length(pathname);
  4591.     found := false; extpos := 0; i := len;
  4592.     while ((not found) and (i >= 1)) do begin
  4593.       thischar := pathname[i];
  4594.       if (thischar = period) then begin
  4595.         found := true;
  4596.         if (
  4597.           (
  4598.             (i > 1) and (pathname[i - 1] <> colon) and
  4599.             (pathname[i - 1] <> period) and (pathname[i - 1] <> fslash) and
  4600.             (pathname[i - 1] <> bslash)
  4601.           ) or
  4602.           (
  4603.             (i < len) and (pathname[i + 1] <> period) and
  4604.             (pathname[i + 1] <> fslash) and (pathname[i + 1] <> bslash)
  4605.           )
  4606.         ) then extpos := i
  4607.       end else dec(i)
  4608.     end;
  4609.     if (extpos > 0) then begin
  4610.       fileext := copy(pathname,extpos,4); i := extpos - 1
  4611.     end else i := len;
  4612.     found := false; dirpos := 0; filelen := 0;
  4613.     while ((not found) and (i >= 1)) do begin
  4614.       thischar := pathname[i];
  4615.       if (
  4616.         (thischar = fslash) or (thischar = bslash) or
  4617.         (thischar = colon) or (thischar = period)
  4618.       ) then begin dirpos := i; found := true end else begin
  4619.         inc(filelen); dec(i)
  4620.       end
  4621.     end;
  4622.     if (filelen > 0) then filename := copy(pathname,dirpos + 1,filelen);
  4623.     if (dirpos > 0) then subdir := copy(pathname,1,dirpos)
  4624.   end;  
  4625.  
  4626.  
  4627.  
  4628.  
  4629.   function __searchrec(
  4630.     src                  : searchrec;
  4631.     nm, woord, mainsize  :      word;
  4632.     takemainsize, extended,
  4633.     ampm, show_attr,
  4634.     wide                 :   boolean
  4635.   ): string;
  4636.  
  4637.   const
  4638.     blank  = #32;
  4639.     zero   = #48;
  4640.     period = #46;
  4641.  
  4642.   var
  4643.     i, j     : word;
  4644.     l,
  4645.     tmpstr   : string;
  4646.     ampmch   : string[1];
  4647.     namestr  : string[8];
  4648.     extstr   : string[4];
  4649.     sizestr  : string[26];
  4650.     datestr  : string;
  4651.     hourstr  : string[4];
  4652.     minstr   : string[2];
  4653.     attrstr  : string[18];
  4654.     dt       : datetime;
  4655.  
  4656.  
  4657.   begin {__searchrec}
  4658.     with src do begin
  4659.       fillchar(namestr[1], 8, blank); namestr[0] := #8;
  4660.       fillchar(extstr[1], 4, blank);  extstr[0] := #4;
  4661.       if (name='.') or (name='..') then move(name[1], namestr[1], length(name))
  4662.       else begin
  4663.         {if ((attr and volumeid) <> 0) then j := 1 else j := 2;} j := 2;
  4664.         i := pos('.', name); if (i = 0) then i := succ(length(name))
  4665.         else move(name[succ(i)], extstr[j], length(name) - i);
  4666.         move(name[1], namestr[1], pred(i));
  4667.       end;
  4668.       if (((attr and directory)<>0) and not takemainsize) then
  4669.         sizestr := ' <DIRECTORY> ' else
  4670.         if (((attr and directory)<>0) and takemainsize) then
  4671.           sizestr := '   <DIR>' else
  4672.           if (((attr and volumeid)<>0) and not takemainsize) then
  4673.             sizestr := ' <VOLUMEID>  ' else
  4674.             if (((attr and volumeid)<>0) and takemainsize) then
  4675.               sizestr := '   <VOL>' else
  4676.               if ((size=0) and not takemainsize) then
  4677.                 sizestr := ' <NULFILE>   ' else
  4678.                 if ((size=0) and takemainsize) then
  4679.                   sizestr := '   <NUL>' else
  4680.                   if takemainsize then sizestr := __juststr(
  4681.                     __pntstr(size) + 'K', ' ', 8, _right_just_str
  4682.                   ) else sizestr := __juststr(
  4683.                       __pntstr(size), ' ', 13, _right_just_str
  4684.                     );
  4685.       if extended then begin
  4686.         if (
  4687.           ((attr and directory) <> 0) or ((attr and volumeid) <> 0) or
  4688.           (size = 0)
  4689.         ) then sizestr := sizestr + ' [USED]' else if not takemainsize then
  4690.           sizestr := sizestr + __juststr(
  4691.             __num(__main(size, mainsize) div 1024) + 'K', ' ', 7,
  4692.             _right_just_str
  4693.           );
  4694.       end;
  4695.  
  4696.       unpacktime(time, dt);
  4697.       with dt do begin
  4698.         if extended then datestr := '' else datestr := ' ';
  4699.         if year * month * day <= 0 then 
  4700.           datestr := datestr + ' ' + __dt2ststr(1993, 1, 1, woord) else
  4701.           datestr := datestr + ' ' + __dt2ststr(year, month, day, woord);
  4702.         if (hour > 12) and ampm then begin dec(hour, 12); ampmch := 'p' end else
  4703.           if ampm then ampmch := 'a' else ampmch := '';
  4704.         str(hour:4, hourstr); str(min:2, minstr);
  4705.         if (minstr[1] = blank) then minstr[1] := zero
  4706.       end;
  4707.       if not extended then attrstr := '  ' else attrstr := ' ';
  4708.       if show_attr then begin
  4709.         if woord <> 4 then begin
  4710.           if (attr and readonly)>0 then attrstr := attrstr + 'R/O ' else
  4711.             attrstr := attrstr + '    ';
  4712.         end else begin
  4713.           if (attr and readonly)>0 then attrstr := attrstr + 'R' else
  4714.             attrstr := attrstr + ' ';
  4715.         end;
  4716.         if woord <> 4 then begin
  4717.           if (attr and   hidden)>0 then attrstr := attrstr + 'Hid ' else
  4718.             attrstr := attrstr + '    ';
  4719.         end else begin
  4720.           if (attr and   hidden)>0 then attrstr := attrstr + 'H' else
  4721.             attrstr := attrstr + ' ';
  4722.         end;
  4723.         if woord <> 4 then begin
  4724.           if (attr and  sysfile)>0 then attrstr := attrstr + 'Sys ' else
  4725.             attrstr := attrstr + '    ';
  4726.         end else begin
  4727.           if (attr and  sysfile)>0 then attrstr := attrstr + 'S' else
  4728.             attrstr := attrstr + ' ';
  4729.         end;
  4730.         if woord <> 4 then begin
  4731.           if (attr and  archive)>0 then attrstr := attrstr + 'Arc ' else
  4732.             attrstr := attrstr + '    '
  4733.         end else begin
  4734.           if (attr and  archive)>0 then attrstr := attrstr + 'A' else
  4735.             attrstr := attrstr + ' '
  4736.         end;
  4737.       end;
  4738.       if not extended then attrstr := attrstr + ' ';
  4739.       if wide then begin
  4740.         namestr := __nw(namestr); extstr := __nw(extstr);
  4741.       end;
  4742.  
  4743.       if wide and ((attr and directory)=0) then begin
  4744.         tmpstr := __juststr(' ' + namestr + '.'+ extstr, ' ', 16, _left_just_str)
  4745.       end else begin
  4746.         if ((attr and directory) > 0) then begin
  4747.           if wide then tmpstr := __juststr(
  4748.             ' [' + namestr + extstr + ']', ' ', 16, _left_just_str
  4749.           ) else tmpstr := __juststr(
  4750.             ' ' + namestr + extstr, ' ', 14, _left_just_str
  4751.           )
  4752.         end else tmpstr := ' '+ __juststr(namestr, ' ', 8, _left_just_str)+'  '+
  4753.           __juststr(extstr, ' ', 3, _right_just_str);
  4754.       end;
  4755.  
  4756.       l := '';
  4757.       if extended then l := __juststr(__num(nm), ' ', 3, _right_just_str);
  4758.       __searchrec := l + tmpstr + sizestr + datestr + hourstr + ':' +
  4759.         minstr + ampmch + attrstr;
  4760.     end;
  4761.   end;  { __searchrec }
  4762.  
  4763.  
  4764.  
  4765.  
  4766.   function  __sizefil(pt: string): longint;
  4767.   var atri: searchrec;
  4768.   begin
  4769.     findfirst(pt, anyfile, atri);
  4770.     __sizefil := atri.size;
  4771.   end;
  4772.  
  4773.  
  4774.  
  4775.  
  4776.   function  __strattr(attr: byte; full: boolean): string;
  4777.   type
  4778.     filterenum = (r_o, hid, sys, vol, dir, arc, bit6, bit7);
  4779.     fs = set of filterenum;
  4780.  
  4781.   const
  4782.     ats: array[filterenum] of string[9] = (
  4783.       'ReadOnly',  'Hidden',    'System',
  4784.       'VolumeID',  'Directory', 'Archive',
  4785.       'Only',      'NotNone'
  4786.     );
  4787.  
  4788.   var
  4789.     st     : string;
  4790.     len    :   byte;
  4791.     filter :     fs;
  4792.  
  4793.   begin
  4794.     filter := fs(attr); st := '';
  4795.     if full then len := 9 else len := 1;
  4796.     if r_o in filter then st := st +        copy(ats[r_o], 1, len);
  4797.     if hid in filter then st := st + ', ' + copy(ats[hid], 1, len);
  4798.     if sys in filter then st := st + ', ' + copy(ats[sys], 1, len);
  4799.     if vol in filter then st := st + ', ' + copy(ats[vol], 1, len);
  4800.     if dir in filter then st := st + ', ' + copy(ats[dir], 1, len);
  4801.     __strattr := st;
  4802.   end;
  4803.  
  4804.  
  4805.  
  4806.   procedure __uniquefil(               { i.s.o. __tempfil, an unique textfile }
  4807.     var pathname: string; var tmpfile: text; var errorcode: word
  4808.   );
  4809.   var
  4810.     pathz   : pathstr;                             { asciiz string for pathname }
  4811.     pathlen : byte;
  4812.     reg     : registers;
  4813.     frec    : textrec;
  4814.  
  4815.   begin
  4816.     pathlen := length(pathname);
  4817.     if (pathname[pathlen] <> _dirslash) then begin { must have a trailing backslash }
  4818.       pathname := pathname + _dirslash; inc(pathlen)
  4819.     end;
  4820.     pathname := __normfil(pathname);
  4821.     move(pathname[1],pathz,pathlen);
  4822.     pathz[pathlen] := #0;
  4823.     with reg do begin                              { call dos function $5a    }
  4824.       ax := $5a00; ds := seg(pathz); dx := ofs(pathz); cx := {fileattr} 0;
  4825.       intr($21,reg);
  4826.       if ((flags and fcarry) <> 0) then errorcode := ax else with frec do begin
  4827.         fillchar(frec, sizeof(frec), #0);
  4828.         errorcode := 0;
  4829.         mode := fminout;
  4830.         (*recsize := {rsize} 1;*)
  4831.         handle := ax;                                  { the dos file handle  }
  4832.         move(pathz,pathname[1],67);                { return new file path name}
  4833.         move(pathz,name,67);
  4834.         pathname[0] := #67;                        { search for the nul  byte }
  4835.         pathname[0] := chr(pos(#0,pathname));                { and set length }
  4836.         textrec(tmpfile) := frec
  4837.       end;
  4838.     end;
  4839.   end; { __uniquefil }
  4840.  
  4841.  
  4842.   {$I-}
  4843.   function __copyfil(show: boolean; x1,x2,y,f,b: byte; fs: longint; src, targ: string): byte;
  4844.   {
  4845.    return codes:
  4846.      0 successful
  4847.      1 source and target the same
  4848.      2 cannot open source
  4849.      3 unable to create target
  4850.      4 error during copy
  4851.      5 cannot allocate buffer
  4852.   }
  4853.   const
  4854.     bufsize = 16384;
  4855.  
  4856.   type
  4857.     fbuf = array[1..bufsize] of char;
  4858.     fbf  = ^fbuf;
  4859.  
  4860.   var
  4861.     source,
  4862.     target   :    file;
  4863.     bread,
  4864.     bwrite   :    word;
  4865.     filebuf  :    ^fbf;
  4866.     tr       : longint;
  4867.     nr       :    real;
  4868.  
  4869.   begin
  4870.     if memavail > bufsize then new(filebuf) else begin __copyfil := 5; exit end;
  4871.     if src = targ then begin __copyfil := 1; exit end;
  4872.     assign(source, src); reset(source,1);
  4873.     if ioresult <> 0 then begin __copyfil := 2; exit end;
  4874.     assign(target, targ); rewrite(target,1);
  4875.     if ioresult <> 0 then begin __copyfil := 3; exit end;
  4876.     if show then __write(x1+2,y,f,b,__rep(x2-x1-3,'░')); tr := 0;
  4877.     repeat
  4878.       blockread(source,filebuf^,bufsize,bread);
  4879.       tr := tr + bread; nr := tr/fs;
  4880.       nr := nr * (x2-x1-3);
  4881.       if show then __write(x1+2,y,f,b,__rep(trunc(nr), '█'));
  4882.       blockwrite(target,filebuf^,bread,bwrite);
  4883.     until (bread = 0) or (bread <> bwrite);
  4884.     if show then __write(x1+2,y,f,b,__rep((x2-x1-3),'█'));
  4885.     close(source); close(target);
  4886.     if bread <> bwrite then __copyfil := 4 else __copyfil := 0;
  4887.   end;
  4888.   {$I-}
  4889.  
  4890.  
  4891.   procedure __renamfil(prevname,newname : pathstr; var errorcode : word);
  4892.   var
  4893.     pathlen : integer;
  4894.     reg     : registers;
  4895.  
  4896.   begin
  4897.     pathlen := length(prevname);           { first transform to asciiz  }
  4898.     move(prevname[1],prevname[0],pathlen); { strings (i.e., trailing    }
  4899.     prevname[pathlen] := #0;               { nul byte).                 }
  4900.     pathlen := length(newname);
  4901.     move(newname[1],newname[0],pathlen);
  4902.     newname[pathlen] := #0;
  4903.  
  4904.     with reg do begin
  4905.       ax := $5600;
  4906.       ds := seg(prevname);           { pointers to the previous and   }
  4907.       dx := ofs(prevname);           { new asciiz strings             }
  4908.       es := seg(newname);
  4909.       di := ofs(newname);
  4910.       intr($21, reg);
  4911.       if ((flags and fcarry) <> 0) then errorcode := ax else errorcode := 0
  4912.     end
  4913.   end;
  4914.  
  4915.  
  4916.   function __slicefil(
  4917.     x1, x2, y, f, b: byte; haksize: longint; src: string
  4918.   ): byte;
  4919.   {
  4920.    return codes:
  4921.      0 successful
  4922.      1 source and target the same
  4923.      2 cannot open source
  4924.      3 unable to create target
  4925.      4 error during copy
  4926.      5 cannot allocate buffer
  4927.   }
  4928.   const
  4929.     bufsize = 16384;
  4930.     max360  = 0360000;
  4931.     max720  = 0720000;
  4932.     max1200 = 1220000;
  4933.     max1440 = 1440000;
  4934.     max2880 = 2880000;
  4935.  
  4936.  
  4937.   type
  4938.     fbuf = array[1..bufsize] of char;
  4939.     fbf  = ^fbuf;
  4940.     str3 = string[3];
  4941.  
  4942.   var
  4943.     source,
  4944.     target       :    file;
  4945.     bread,
  4946.     bwrite       :    word;
  4947.     filebuf      :    ^fbf;
  4948.     maxondisc,
  4949.     sessionread,
  4950.     vn, tr, fs   : longint;
  4951.     nr           :    real;
  4952.     targ         :  string;
  4953.  
  4954.  
  4955.     function __volgnum(l: longint): str3;
  4956.     begin
  4957.       __volgnum := __juststr(__num(l), '0', 3, _right_just_str)
  4958.     end;
  4959.  
  4960.  
  4961.   begin
  4962.     src := __normfil(src); fs := __sizefil(src); targ := __extractname(src);
  4963.     if diskfree(byte(src[1])-byte('A')+1)<fs then begin __slicefil := 6; exit end;
  4964.     if haksize = 360 then maxondisc := max360;
  4965.     if haksize = 720 then maxondisc := max720;
  4966.     if haksize = 1200 then maxondisc := max1200;
  4967.     if haksize = 1440 then maxondisc := max1440;
  4968.     if haksize = 2880 then maxondisc := max2880;
  4969.     if haksize = 0 then maxondisc := max1440 else maxondisc := __main(haksize, 16384);
  4970.     if memavail > bufsize then new(filebuf) else begin __slicefil := 5; exit end;
  4971.     if src = targ then begin __slicefil := 1; exit end;
  4972.     assign(source, src); reset(source,1);
  4973.     if ioresult <> 0 then begin __slicefil := 2; exit end;
  4974.     __write(x1,y,f,b,__rep(x2-x1-1,'░'));
  4975.     tr := 0; { keeps track on total bytes written for statusbar }
  4976.     vn := 1; { virtual number for numbering the chunks }
  4977.     repeat   
  4978.       assign(target, targ + '.' + __volgnum(vn)); rewrite(target,1);
  4979.       if ioresult <> 0 then begin __slicefil := 3; exit end;
  4980.       sessionread := 0; { keeps track on bytes written to ONE CHUNK }
  4981.       __write(50, y, f, b, 'Writing chunk ' + targ + '.' + __volgnum(vn));
  4982.       repeat
  4983.         blockread(source,filebuf^,bufsize,bread);
  4984.         inc(sessionread, bread); inc(tr, bread); nr := tr/fs;
  4985.         nr := nr * (x2-x1-3);
  4986.         __write(x1, y, f, b, __rep(trunc(nr), '█'));
  4987.         blockwrite(target,filebuf^,bread,bwrite);
  4988.       until (bread = 0) or (bread <> bwrite) or (sessionread >= maxondisc);
  4989.       inc(vn);
  4990.       close(target);
  4991.     until (bread = 0) or (bread <> bwrite);
  4992.     __write(x1, y, f, b, __rep((x2-x1-1),'█'));
  4993.     close(source);
  4994.     if bread <> bwrite then __slicefil := 4 else __slicefil := 0;
  4995.   end;
  4996.   {$I-}
  4997.  
  4998.  
  4999.  
  5000.   { $ L rdsector}
  5001.   procedure rdsector(driveno : word; var errorcode : word); external;
  5002.  
  5003.   function  __isdrvfil(drive : char; var errorcode : word) : boolean;
  5004.   const
  5005.     needtoread = 99;
  5006.   
  5007.   var
  5008.     driveno    : word;
  5009.     lastdrive  : word;
  5010.     reg        : registers;
  5011.   
  5012.   begin 
  5013.     with reg do begin
  5014.       ah := $19;                     
  5015.       intr($21, reg);
  5016.   
  5017.       ah := $0e;                     
  5018.       dl := al;                      
  5019.       intr($21, reg);                
  5020.       dec(al);                       
  5021.       lastdrive := al
  5022.     end;
  5023.   
  5024.     driveno := word(upcase(drive)) - word('A');
  5025.     if (driveno > lastdrive) then errorcode := 1 else begin
  5026.       errorcode := needtoread;
  5027.       if (_dosmajorver >= 3) then with reg do begin
  5028.         ah := $44;              
  5029.         al := $08;              
  5030.         bl := driveno + 1;      
  5031.         intr($21, reg);
  5032.         if ((flags and fcarry = 0) and (ax = 1)) then errorcode := 0;      
  5033.       end;
  5034.       if (errorcode = needtoread) then begin
  5035.         rdsector(driveno,errorcode);
  5036.         if (errorcode <> 0) then if (errorcode = $0207) then begin
  5037.           if (_dosmajorver >= 4) then errorcode := 0 else
  5038.             if (
  5039.               {(_compaq) and} (_dosmajorver >=3 ) and (_dosminorver >= 31)
  5040.             ) then errorcode := 0 else errorcode := 3
  5041.         end else if (errorcode = $8002) then errorcode := 2 else
  5042.           if (errorcode = driveno) then errorcode := 1 else
  5043.             if (errorcode >= 3) then errorcode := 3;    
  5044.       end                        
  5045.     end;
  5046.     __isdrvfil := (errorcode = 0)
  5047.   end;  
  5048.  
  5049.  
  5050.  
  5051.   function  __retdtfil : pointer;
  5052.   var reg : registers;
  5053.   begin
  5054.     with reg do begin
  5055.       ah := $2f;                     
  5056.       intr($21, reg);
  5057.       __retdtfil := ptr(es,bx)
  5058.     end
  5059.   end;
  5060.   
  5061.   
  5062.   procedure __setdtfil(dtaaddress : pointer);
  5063.   var reg : registers;
  5064.   begin 
  5065.     with reg do begin
  5066.       ah := $1a;                     
  5067.       ds := _vectoraddr(dtaaddress)._seg;
  5068.       dx := _vectoraddr(dtaaddress)._ofs
  5069.     end;
  5070.     intr($21, reg)
  5071.   end;  
  5072.   
  5073.   function __retvlfil(drive : char; var volstamp : longint) : string;
  5074.   var
  5075.     extendedfcb : array[-7..36] of byte;
  5076.     dtaptr      :               pointer;
  5077.     tempdta     :  array[0..44] of byte;
  5078.     driveno     :                  byte;
  5079.     volname     :                string;
  5080.     reg         :             registers;
  5081.   
  5082.   begin 
  5083.     dtaptr  := __retdtfil;
  5084.     __setdtfil(@tempdta);
  5085.     driveno := byte(upcase(drive)) - byte('A') + 1;
  5086.     extendedfcb[-7] := $ff;
  5087.     extendedfcb[-1] := $08;
  5088.     extendedfcb[0]  := driveno;
  5089.     fillchar(extendedfcb[1],11,$3f);   
  5090.     fillchar(extendedfcb[12],25,0);    
  5091.   
  5092.     with reg do begin
  5093.       ah := $11;
  5094.       ds := seg(extendedfcb);
  5095.       dx := ofs(extendedfcb);
  5096.       intr($21, reg);
  5097.       if (al = $ff) then begin
  5098.         volstamp   := 0;
  5099.         __retvlfil := ''
  5100.       end else begin                       
  5101.         move(tempdta,extendedfcb[-7],39);  
  5102.         move(extendedfcb[1],volname[1],11);
  5103.         volname[0] := #11;
  5104.         __retvlfil := volname;
  5105.         move(extendedfcb[23],volstamp,4);
  5106.       end
  5107.     end;
  5108.     __setdtfil(dtaptr)               
  5109.   end;
  5110.  
  5111.  
  5112.  
  5113.   function __handlfil(var filevar) : word;
  5114.   begin
  5115.     if (filerec(filevar).mode = fmclosed) then __handlfil := $ffff else
  5116.       __handlfil := filerec(filevar).handle
  5117.   end;
  5118.  
  5119.  
  5120.   function  __isconfil(handle : word) : boolean;
  5121.   var reg : registers;
  5122.   begin
  5123.     with reg do begin
  5124.       ah := $44;     
  5125.       al := 0;         
  5126.       bx := handle;
  5127.       intr($21,reg);
  5128.       __isconfil := ((dl and $80) <> 0) and ((dl and $03) <> 0)
  5129.     end
  5130.   end;
  5131.  
  5132.  
  5133.   
  5134.  
  5135.  
  5136.   {$F+}
  5137.   function callcondition(var search): boolean;
  5138.   inline($ff/$1e/conditionfuncptr_);
  5139.  
  5140.  
  5141.  
  5142.   {$F+}
  5143.   function no_condition(var srec): boolean;
  5144.   begin
  5145.     no_condition := true;
  5146.   end;
  5147.  
  5148.  
  5149.  
  5150.   {$F+}
  5151.   function std_condition(var srec): boolean;
  5152.   var sr: searchrec;
  5153.   begin
  5154.     sr := searchrec(srec);
  5155.     with std_condition_attrs do std_condition := (
  5156.       (show_r_o or not((sr.attr and readonly ) > 0)) and
  5157.       (show_hid or not((sr.attr and hidden   ) > 0)) and
  5158.       (show_sys or not((sr.attr and sysfile  ) > 0)) and
  5159.       (show_arc or not((sr.attr and archive  ) > 0)) and
  5160.       (show_vol or not((sr.attr and volumeid ) > 0)) and
  5161.       (show_dir or not((sr.attr and directory) > 0)) and
  5162.       (show_non or (
  5163.           ((sr.attr and readonly) > 0) or
  5164.           ((sr.attr and hidden  ) > 0) or
  5165.           ((sr.attr and archive ) > 0) or
  5166.           ((sr.attr and sysfile ) > 0)
  5167.         )
  5168.       )
  5169.     );
  5170.   end; { std_conditio }
  5171.  
  5172.  
  5173.  
  5174.   {$F+}
  5175.   function std_sort(var data1, data2): boolean;
  5176.   var
  5177.     st1, st2: string[3];
  5178.     in1, in2:   integer;
  5179.     dt1, dt2:  datetime;
  5180.     li1, li2:   longint;
  5181.     sr1, sr2: searchrec;
  5182.  
  5183.   begin
  5184.     sr1 := searchrec(pointer(data1)^);
  5185.     sr2 := searchrec(pointer(data2)^);
  5186.     if (
  5187.       ((sr1.attr and volumeid) > 0) and
  5188.       not( (sr2.attr and volumeid) > 0 )
  5189.     ) then std_sort := true else if (
  5190.       ((sr1.attr and directory) > 0) and
  5191.       not( (sr2.attr and directory) > 0 )
  5192.     ) then std_sort := true else if (
  5193.       not( (sr1.attr and directory) > 0) and
  5194.       ((sr2.attr and directory) > 0 )
  5195.     ) then std_sort := false else if (
  5196.       ((sr1.attr and directory) > 0) and
  5197.       ((sr2.attr and directory) > 0)
  5198.     ) then std_sort := (sr1.name < sr2.name) else
  5199.     case std_condition_attrs.sort_method of
  5200.       on_name: std_sort := sr1.name < sr2.name;
  5201.       on_extension: if __comp(
  5202.         __extractext(sr1.name), __extractext(sr2.name)
  5203.       ) then std_sort := sr1.name < sr2.name else if (
  5204.         (__extractext(sr1.name) <> '') and (__extractext(sr2.name) <> '')
  5205.       ) then std_sort := (__extractext(sr1.name) < __extractext(sr2.name)) else
  5206.         if not __comp(__extractext(sr1.name), '') then std_sort := true else
  5207.           std_sort := false;
  5208.       on_datetime: begin { by date and time }
  5209.         unpacktime(sr1.time, dt1); unpacktime(sr2.time, dt2);
  5210.         li1 := __dt2jlutl(dt1.year, dt1.month, dt1.day);
  5211.         li2 := __dt2jlutl(dt2.year, dt2.month, dt2.day);
  5212.         if li1 <> li2 then std_sort := li1 < li2 else std_sort := (
  5213.           (dt1.hour*10000 + dt1.min*100 + dt1.sec) < 
  5214.           (dt2.hour*10000 + dt2.min*100 + dt2.sec)
  5215.         );
  5216.       end;
  5217.       on_size: std_sort := sr1.size < sr2.size; { by size }
  5218.     end; { case }
  5219.   end; { std_sort }
  5220.   {$F-}
  5221.  
  5222.  
  5223.  
  5224.   procedure new_filarray(var fil: filarraytypeptr);
  5225.   var i : word;
  5226.   begin
  5227.     new(fil); for i := 1 to maxfiles do fil^[i] := nil;
  5228.   end;
  5229.  
  5230.  
  5231.   procedure dispose_filarray(var fil: filarraytypeptr);
  5232.   var i : word;
  5233.   begin
  5234.     for i := 1 to maxfiles do begin
  5235.       {writeln(__ptr2str(fil^[i]));}
  5236.       if fil^[i] <> nil then dispose(fil^[i]);
  5237.     end;
  5238.     dispose(fil);
  5239.   end;
  5240.  
  5241.  
  5242.   {$F+}
  5243.   procedure set_std_condition_attrs(attrs: condition_attrstype);
  5244.   begin
  5245.     std_condition_attrs := attrs;
  5246.   end;
  5247.  
  5248.  
  5249.   procedure __dirutl;
  5250.   const
  5251.     no_error      = 0;
  5252.     invalid_path  = 3;
  5253.     mem_error     = 8;
  5254.     no_more_files = 18;
  5255.  
  5256.   var
  5257.     srec : searchrec;
  5258.     i    :      word;
  5259.     tt   :   longint;
  5260.  
  5261.   begin
  5262.     tt := 0;
  5263.     if condit = nil then conditionfuncptr_ := @no_condition else
  5264.       conditionfuncptr_ := condit;
  5265.     filitems := 0; vol_counted := false; error := 0;
  5266.  
  5267.     findfirst(searchpath, searchattr, srec);
  5268.     if (doserror = invalid_path) then begin
  5269.       error := invalid_path; exit
  5270.     end else if (doserror = no_more_files) then exit;
  5271.  
  5272.     tt := 0; counted_dirs := 0;
  5273.  
  5274.     while (doserror = 0) do begin
  5275.       if (
  5276.         (comexebatcmdfilter and __comexebatcmdfilter(srec.name)) or
  5277.         (not comexebatcmdfilter)
  5278.       ) then begin
  5279.         if callcondition(srec) then begin
  5280.           if not(
  5281.             ((srec.attr and volumeid) > 0) or
  5282.             ((srec.attr and directory) > 0)
  5283.           ) then begin
  5284.             if (
  5285.               manipulate = _to_lowcase_str 
  5286.             ) then srec.name := __lo(srec.name) else if (
  5287.               manipulate = _to_upcase_str
  5288.             ) then srec.name := __up(srec.name);
  5289.             tt := tt + srec.size;
  5290.           end else srec.name := __up(srec.name);
  5291.           inc(filitems); if renew_space then new(filar^[filitems]);
  5292.           filar^[filitems]^ := srec;
  5293.           if ((srec.attr and volumeid) > 0) then vol_counted := true;
  5294.           if ((srec.attr and directory) > 0) then inc(counted_dirs);
  5295.         end; { test condition, if ok, get it }
  5296.       end;
  5297.       findnext(srec);
  5298.     end;
  5299.     totnum := tt;
  5300.  
  5301.     if sorter <> nil then __qsortsrt(
  5302.       filar, filitems, sizeof(pointer), sorter
  5303.     );
  5304.   end; { __dirutl }
  5305.  
  5306.  
  5307.  
  5308.  
  5309.  
  5310.  
  5311.   procedure addtogethertwotimerecords(
  5312.     timerecordone : timerecord;
  5313.     timerecordtwo : timerecord;
  5314.     var resultrecord  : timerecord
  5315.   ); {this is an internal procedure.}
  5316.   begin {additionoftwotimes}
  5317.     resultrecord.hundredth := (timerecordone.hundredth+timerecordtwo.hundredth);
  5318.     resultrecord.second    := (timerecordone.second   +timerecordtwo.second);
  5319.     resultrecord.minute    := (timerecordone.minute   +timerecordtwo.minute);
  5320.     resultrecord.hour      := (timerecordone.hour     +timerecordtwo.hour);
  5321.     while (resultrecord.hundredth >= 100) do begin
  5322.       dec(resultrecord.hundredth,100); inc(resultrecord.second)
  5323.     end;
  5324.     while (resultrecord.second >= 60) do begin
  5325.       dec(resultrecord.second,60); inc(resultrecord.minute)
  5326.     end;
  5327.     while (resultrecord.minute >= 60) do begin
  5328.       dec(resultrecord.minute,60); inc(resultrecord.hour)
  5329.     end
  5330.   end;
  5331.  
  5332.  
  5333.  
  5334.   procedure addonedaytodate(var thedaterecord : daterecord);
  5335.   begin
  5336.     with thedaterecord do begin
  5337.       inc(date);
  5338.       case month of
  5339.         1,3,5,7,8,10,12: if (date > 31) then begin dec(date,31); inc(month) end;
  5340.         4, 6, 9, 11    : if (date > 30) then begin dec(date,30); inc(month) end;
  5341.         2 : if (date > 29) then begin dec(date,29); month := 3 end else
  5342.           if (
  5343.             (date > 28) and not (((year mod 4) = 0) and
  5344.             (((year mod 100) <> 0) or ((year mod 400) = 0)))
  5345.           ) then begin dec(date,28); month := 3 end
  5346.       end; {case month}
  5347.       while (month > 12) do begin dec(month,12); inc(year) end;
  5348.       inc(dayofweek); dayofweek := (dayofweek mod 7)
  5349.     end {with thedaterec}
  5350.   end;
  5351.  
  5352.  
  5353.  
  5354.   function juliandate(thedate : daterecord) : longint;
  5355.   var templongint : longint;
  5356.   begin
  5357.     templongint := thedate.year;
  5358.     templongint := (templongint * 1000);
  5359.     case thedate.month of
  5360.       02 : inc(templongint,31);
  5361.       03 : inc(templongint,59);
  5362.       04 : inc(templongint,90);
  5363.       05 : inc(templongint,120);
  5364.       06 : inc(templongint,151);
  5365.       07 : inc(templongint,181);
  5366.       08 : inc(templongint,212);
  5367.       09 : inc(templongint,243);
  5368.       10 : inc(templongint,273);
  5369.       11 : inc(templongint,304);
  5370.       12 : inc(templongint,334)
  5371.     end; {case daterecord.month}
  5372.     if (((thedate.year mod 4) = 0) and (thedate.month > 2)) then
  5373.       if (((thedate.year mod 100) <> 0) or ((thedate.year mod 400) = 0))
  5374.         then inc(templongint); {add a day for leapyears}
  5375.     templongint := (templongint + thedate.date);
  5376.     juliandate := templongint
  5377.   end;
  5378.  
  5379.  
  5380.  
  5381.   procedure subtractonedayfromdate(var thedaterecord : daterecord);
  5382.   begin
  5383.     with thedaterecord do begin
  5384.       if date = 1 then begin
  5385.         if month = 1 then begin dec(year); month := 12; date := 31 end else begin
  5386.           dec(month);
  5387.           case month of
  5388.             1, 3, 5, 7, 8, 10, 12 : date := 31;
  5389.             4, 6, 9, 11           : date := 30;
  5390.             2 : if (((year mod 4) = 0) and
  5391.                    (((year mod 100) <> 0) or ((year mod 400) = 0)))
  5392.                  then date := 29 else date := 28
  5393.           end {case month}
  5394.         end
  5395.       end else dec(date);
  5396.       if (dayofweek = 0) then dayofweek := 6 else dec(dayofweek)
  5397.     end {with thedaterec}
  5398.   end;
  5399.  
  5400.  
  5401.  
  5402.  
  5403.   function  converttimetostring(thetimerec : timerecord) : string;
  5404.   var
  5405.     tempstring1 : string;
  5406.     tempstring2 : string;
  5407.     index       :   byte;
  5408.  
  5409.   begin
  5410.     str(thetimerec.hour:2,{var} tempstring1);
  5411.     str(thetimerec.minute:2,{var} tempstring2);
  5412.     tempstring1 := (tempstring1 + colon + tempstring2);
  5413.     str(thetimerec.second:2,{var} tempstring2);
  5414.     tempstring1 := (tempstring1 + period + tempstring2);
  5415.     str(thetimerec.hundredth:2,{var} tempstring2);
  5416.     tempstring1 := (tempstring1 + separ + tempstring2);
  5417.     for index := 1 to length(tempstring1) do
  5418.       if (tempstring1[index] = space) then tempstring1[index] := zero;
  5419.     converttimetostring := tempstring1
  5420.   end;
  5421.  
  5422.  
  5423.  
  5424.  
  5425.   function  datesareequal(
  5426.     daterecord1 : daterecord;
  5427.     daterecord2 : daterecord
  5428.   ) : boolean;
  5429.   begin
  5430.     if (
  5431.       (daterecord1.date = daterecord2.date) and
  5432.       (daterecord1.month = daterecord2.month) and
  5433.       (daterecord1.year = daterecord2.year)
  5434.     ) then datesareequal := true else datesareequal := false
  5435.   end;
  5436.  
  5437.  
  5438.  
  5439.  
  5440.   function  juliantime(timerecord : timerecord) : longint;
  5441.   var
  5442.     templongint  : longint;
  5443.     tempvariable : longint;
  5444.  
  5445.   begin
  5446.     templongint  := timerecord.hour;
  5447.     templongint  := (templongint * 1000000);
  5448.     tempvariable := timerecord.minute;
  5449.     templongint  := (
  5450.       templongint + (tempvariable * 10000) + (timerecord.second * 100) +
  5451.       timerecord.hundredth
  5452.     );
  5453.     juliantime := templongint
  5454.   end;
  5455.  
  5456.  
  5457.  
  5458.  
  5459.   procedure determinelengthbetweentwodatetimes(
  5460.     startdaterecord       : daterecord;
  5461.     starttimerecord       : timerecord;
  5462.     enddaterecord         : daterecord;
  5463.     endtimerecord         : timerecord;
  5464.     var elapsedtimerecord : timerecord
  5465.   );
  5466.   var julianenddate : longint;
  5467.   begin
  5468.     with elapsedtimerecord do begin
  5469.       hour := 0; minute := 0; second := 0; hundredth := 0
  5470.     end;
  5471.     if (
  5472.       (juliandate(startdaterecord) > juliandate(enddaterecord)) or
  5473.       (datesareequal(startdaterecord,enddaterecord) and
  5474.       (juliantime(starttimerecord) > juliantime(endtimerecord)))
  5475.     ) then addonedaytodate({var} enddaterecord);
  5476.     while (endtimerecord.hundredth < starttimerecord.hundredth) do begin
  5477.       inc(endtimerecord.hundredth,100);
  5478.       if (endtimerecord.second = 0) then begin
  5479.         endtimerecord.second := 59;
  5480.         if (endtimerecord.minute = 0) then begin
  5481.           endtimerecord.minute := 59;
  5482.           if (endtimerecord.hour = 0) then begin
  5483.             endtimerecord.hour := 23;
  5484.             subtractonedayfromdate(enddaterecord)
  5485.           end else dec(endtimerecord.hour)
  5486.         end else dec(endtimerecord.minute)
  5487.       end else dec(endtimerecord.second)
  5488.     end;
  5489.     elapsedtimerecord.hundredth := (
  5490.       endtimerecord.hundredth - starttimerecord.hundredth
  5491.     );
  5492.     while (endtimerecord.second < starttimerecord.second) do begin
  5493.       inc(endtimerecord.second,60);
  5494.       if (endtimerecord.minute = 0) then begin
  5495.         endtimerecord.minute := 59;
  5496.         if (endtimerecord.hour = 0) then begin
  5497.           endtimerecord.hour := 23;
  5498.           subtractonedayfromdate(enddaterecord)
  5499.         end else dec(endtimerecord.hour)
  5500.       end else dec(endtimerecord.minute)
  5501.     end;
  5502.  
  5503.     elapsedtimerecord.second := (endtimerecord.second - starttimerecord.second);
  5504.     while (endtimerecord.minute < starttimerecord.minute) do begin
  5505.       inc(endtimerecord.minute,60);
  5506.       if (endtimerecord.hour = 0) then begin
  5507.         endtimerecord.hour := 23;
  5508.         subtractonedayfromdate(enddaterecord)
  5509.       end else dec(endtimerecord.hour)
  5510.     end;
  5511.     elapsedtimerecord.minute := (endtimerecord.minute - starttimerecord.minute);
  5512.     while (endtimerecord.hour < starttimerecord.hour) do begin
  5513.       inc(endtimerecord.hour,24);
  5514.       subtractonedayfromdate(enddaterecord)
  5515.     end; {while (endtimerecord.hour < starttimerecord.hour)}
  5516.     elapsedtimerecord.hour := (endtimerecord.hour - starttimerecord.hour);
  5517.     julianenddate := juliandate(enddaterecord);
  5518.     while (juliandate(startdaterecord) <> julianenddate) do begin
  5519.       inc(elapsedtimerecord.hour,24);
  5520.       addonedaytodate({var} startdaterecord)
  5521.     end
  5522.   end;
  5523.  
  5524.  
  5525.  
  5526.  
  5527.   procedure starttimer (whichclock : byte);
  5528.   begin {starttimer}
  5529.     if (whichclock = 0) then exit else {can't reset the program-timer clock!}
  5530.     with clockarray[whichclock] do begin
  5531.       with clockstartdate do getdate({var} year,month,date,dayofweek);
  5532.       with clockstarttime do gettime({var} hour,minute,second,hundredth);
  5533.       with elapsedtime do begin
  5534.         hour := 0; minute := 0; second := 0; hundredth := 0
  5535.       end;
  5536.       clockisrunning := true
  5537.     end
  5538.   end;
  5539.  
  5540.  
  5541.  
  5542.  
  5543.   function  getlaptime (whichclock : byte) : string;
  5544.   var
  5545.     currentdate : daterecord;
  5546.     currenttime : timerecord;
  5547.     elapsedtime : timerecord;
  5548.     tempstring  : string[3];
  5549.  
  5550.   begin
  5551.     with currentdate do getdate({var} year,month,date,dayofweek);
  5552.     with currenttime do gettime({var} hour,minute,second,hundredth);
  5553.     fillchar(elapsedtime,sizeof(elapsedtime),nullchar);
  5554.     str(whichclock,{var} tempstring);
  5555.  
  5556.     determinelengthbetweentwodatetimes(
  5557.       clockarray[whichclock].clockstartdate,
  5558.       clockarray[whichclock].clockstarttime,
  5559.       currentdate, currenttime,
  5560.       {var} elapsedtime
  5561.     );
  5562.     addtogethertwotimerecords(
  5563.       elapsedtime, clockarray[whichclock].elapsedtime, {var} elapsedtime
  5564.     );
  5565.     getlaptime := converttimetostring(elapsedtime)
  5566.   end;
  5567.  
  5568.  
  5569.  
  5570.  
  5571.   procedure restarttimer (whichclock : byte);
  5572.   begin
  5573.     with clockarray[whichclock] do begin
  5574.       with clockstartdate do getdate({var} year,month,date,dayofweek);
  5575.       with clockstarttime do gettime({var} hour,minute,second,hundredth);
  5576.       clockisrunning := true
  5577.     end
  5578.   end;
  5579.  
  5580.  
  5581.  
  5582.  
  5583.  
  5584.   function  stoptimer (whichclock : byte) : string;
  5585.   const cantstopclockzerotext = 'Can''t stop clock #0!';
  5586.   var
  5587.     currentdate : daterecord;
  5588.     currenttime : timerecord;
  5589.     elapsedtime : timerecord;
  5590.     tempstring  : string[3];
  5591.  
  5592.   begin
  5593.     if (
  5594.       (whichclock = 0) or (not clockarray[whichclock].clockisrunning)
  5595.     ) then stoptimer := (cantstopclockzerotext) else begin
  5596.       with currentdate do getdate({var} year,month,date,dayofweek);
  5597.       with currenttime do gettime({var} hour,minute,second,hundredth);
  5598.       fillchar(elapsedtime,sizeof(elapsedtime),nullchar);
  5599.       str(whichclock,{var} tempstring);
  5600.  
  5601.       determinelengthbetweentwodatetimes(
  5602.         clockarray[whichclock].clockstartdate,
  5603.         clockarray[whichclock].clockstarttime,
  5604.         currentdate, currenttime, {var} elapsedtime
  5605.       );
  5606.  
  5607.       addtogethertwotimerecords(
  5608.         elapsedtime, clockarray[whichclock].elapsedtime,
  5609.         {var} clockarray[whichclock].elapsedtime
  5610.       );
  5611.  
  5612.       clockarray[whichclock].clockisrunning := false;
  5613.       stoptimer := converttimetostring(elapsedtime)
  5614.     end
  5615.   end;
  5616.  
  5617.  
  5618.  
  5619.   procedure __setpurge(b: byte);
  5620.   begin
  5621.     purge := b - 1;
  5622.   end;
  5623.  
  5624.  
  5625.  
  5626.   procedure __filapp(fil, s : string);
  5627.   var
  5628.     i       : byte;
  5629.     logfile : text;
  5630.  
  5631.   begin
  5632.     {$I-}
  5633.     assign(logfile, fil);
  5634.     if __existfil(fil) then append(logfile) else rewrite(logfile);
  5635.     writeln(logfile, s); close(logfile);
  5636.     {$I+}
  5637.   end; { __filapp }
  5638.  
  5639.  
  5640.  
  5641.   procedure __logapp(s: string);
  5642.   var
  5643.     i       : byte;
  5644.     logfile : text;
  5645.  
  5646.   begin
  5647.     assign(logfile, logfilename);
  5648.     if __existfil(logfilename) then append(logfile) else begin
  5649.       rewrite(logfile);
  5650.       for i := 1 to 11 do writeln(logfile, logheader[i]);
  5651.       writeln(logfile);
  5652.       writeln(logfile, __curdate + '  LOGfile for ' + programname + ' created.');
  5653.       writeln(logfile); writeln(logfile);
  5654.     end;
  5655.     if s<>'' then writeln(logfile, __curdate + '  ' + s) else writeln(logfile);
  5656.     close(logfile);
  5657.   end; { __logapp }
  5658.  
  5659.  
  5660.  
  5661.   function __recent(s: string): boolean;
  5662.   var                                           { 27 Jul 91  08:34.12 }
  5663.     c       :   char;
  5664.     y, m, d :   word;
  5665.     st, st2 : string;
  5666.  
  5667.   begin
  5668.     st := 'JFMAMJJASOND'; d := __str(copy(s, 1, 2)); m := mo;
  5669.     c := s[4]; st2 := copy(s, 4, 3);
  5670.     case c of
  5671.       'A': if st2='Apr' then m := 4 else m := 8;
  5672.       'D', 'F', 'N', 'O', 'S': m := pos(c, st);
  5673.       'J': if st2='Jan' then m := 1 else if st2='Jun' then m := 6 else m := 7;
  5674.       'M': if st2='Mar' then m := 3 else m := 5;
  5675.     end;
  5676.     y := __str(copy(s, 8, 2));
  5677.     {
  5678.       use of yr mo & day, because in logpurge, they're set with datestr (today)
  5679.       global variables, within scope of implementation
  5680.     }
  5681.     __recent := abs(__daysutl(yr, mo, da, y, m, d)) <= purge
  5682.   end;
  5683.  
  5684.  
  5685.  
  5686.   procedure __logpurge;
  5687.   type buf = array[1..16386] of char;
  5688.   var
  5689.     tin, tou     :   text;
  5690.     bin, bou     :    buf;
  5691.     lin          : string;
  5692.  
  5693.   begin
  5694.     lin := __datestr(yr, mo, da);
  5695.     assign(tin, logfilename); reset(tin); settextbuf(tin, bin);
  5696.     assign(tou, 'eco_log.$$$'); rewrite(tou); settextbuf(tou, bou);
  5697.     for i := 1 to 15 do begin readln(tin, lin); writeln(tou, lin) end;
  5698.  
  5699.     readln(tin, lin);
  5700.     while not(eof(tin)) and (
  5701.       (lin='') or not(lin[1] in ['0','1','2','3']) or not(__recent(lin))
  5702.     ) do begin inc(lines); readln(tin, lin) end;
  5703.     if not eof(tin) then writeln(tou, lin);
  5704.     while not(eof(tin)) do begin
  5705.       inc(lines); readln(tin, lin); writeln(tou, lin)
  5706.     end;
  5707.     close(tin); close(tou);
  5708.     __erasefil(logfilename, error); rename(tou, logfilename);
  5709.   end;
  5710.  
  5711.  
  5712.  
  5713.   procedure __loginit;
  5714.   begin
  5715.     logheader[01] := '┌────────────────────────────────────────────────────────────┐';
  5716.     logheader[02] := '│ ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄ │';
  5717.     logheader[03] := '│ █                                                        █ │';
  5718.     logheader[04] := '│ █                                                        █ │';
  5719.     logheader[05] := '│ █                 E  C  O  P  U  R  G  E                 █ │';
  5720.     logheader[06] := '│ █                                                        █ │';
  5721.     logheader[07] := '│ █                                                        █ │';
  5722.     logheader[08] := '│ █                                                        █ │';
  5723.     logheader[09] := '│ ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀ │';
  5724.     logheader[10] := '│   All material is protected and licensed.  Version 0.00    │';
  5725.     logheader[11] := '└────────────────────────────────────────────────────────────┘';
  5726.   end;
  5727.  
  5728.  
  5729.  
  5730.  
  5731.   function __rep(n: byte; character: char): string;
  5732.   var tempstr: string;
  5733.   begin
  5734.     if n = 0 then tempstr := '' else begin
  5735.       if (n > 255) then n := 1; fillchar(tempstr,n+1,character);
  5736.       tempstr[0] := chr(n);
  5737.     end; __rep := tempstr;
  5738.   end;
  5739.  
  5740.  
  5741.   function  __loc(x, y : byte; var fore, back : byte): char;
  5742.   var
  5743.     pos : _scnpos;
  5744.  
  5745.   begin
  5746.     pos := _scnloc^[((y-1) * _curcolumns) + x];
  5747.     back := pos._attr; back := back shr 4; fore := pos._attr;
  5748.     fore := fore shl 4; fore := fore shr 4;
  5749.     __loc := pos._ch;
  5750.   end;
  5751.  
  5752.  
  5753.   function at(f, b : byte): byte;
  5754.   begin
  5755.     at := (b shl 4) or f
  5756.   end;
  5757.  
  5758.   procedure __scn(col,row,attr:byte; st: str80); external;
  5759.   procedure __vid(col,row:     byte; st: str80); external;
  5760.   procedure changeattr(col,row,attr:byte; number:word); external;
  5761.   procedure __speedscn(
  5762.     sourceptr,targetptr : pointer;
  5763.         count,option,attribute : word;
  5764.         wait : boolean
  5765.   ); external;
  5766.  
  5767.  
  5768.  
  5769.  
  5770.   function  get_video_mode: byte;
  5771.   var regs : registers;
  5772.   begin
  5773.     with regs do begin
  5774.       ax := $0F00; intr($10, regs); get_video_mode := al;
  5775.     end;
  5776.   end;
  5777.  
  5778.  
  5779.   procedure __movescn(
  5780.     x1, y1, x2, y2: byte; bufferptr: pointer; toscreen: boolean
  5781.   );
  5782.   var
  5783.     bufptr      : _scnimageptr absolute bufferptr;
  5784.     scnptr      : _scnimageptr;
  5785.     pagelength  : word absolute _biosseg:$004c;
  5786.     offset      : word;                { offset into video buffer       }
  5787.     width       : word;                { width, in pairs, of each line  }
  5788.     delta       : word;                { increment between data lines   }
  5789.     lines       : word;                { number of lines to access      }
  5790.     wait        : boolean;
  5791.     i,j,k       : word;
  5792.  
  5793.   begin {__movescn}
  5794.     if ((_curmode > 3) and (_curmode <> 7)) then exit; { not textmode }
  5795.     if (x1 < 1) then x1 := 1 else if (x1 > _curcolumns) then x1 := _curcolumns;
  5796.     if (y1 < 1) then y1 := 1 else if (y1 > _currows) then y1 := _currows;
  5797.     if (x2 < x1) then x2 := x1 else if (x2>_curcolumns) then x2 := _curcolumns;
  5798.     if (y2 < y1) then y2 := y1 else if (y2 > _currows) then y2 := _currows;
  5799.     offset := ((y1 - 1) * _curcolumns) + x1;
  5800.     width  := x2 - x1 + 1; delta  := _curcolumns - x2 + x1 - 1;
  5801.     lines  := y2 - y1 + 1;
  5802.     if (_curdisplaypage <> 0) then scnptr := ptr(
  5803.       _vectoraddr(_scnloc)._seg,
  5804.      _vectoraddr(_scnloc)._ofs + (pagelength * _curdisplaypage)
  5805.     ) else scnptr := _scnloc;
  5806.     wait := false;
  5807.  
  5808.     j := offset; k := 1;
  5809.     for i := 1 to lines do begin
  5810.       if (toscreen) then __speedscn(
  5811.         @bufptr^[k], @scnptr^[j], width, 2, 0, wait
  5812.       ) else __speedscn(
  5813.         @scnptr^[j], @bufptr^[k], width, 3, 0, wait
  5814.       );
  5815.       inc(j,width + delta);
  5816.       inc(k,width);
  5817.     end
  5818.   end; { __movescn }
  5819.  
  5820.  
  5821.  
  5822.   procedure __boxscn(x1,y1,x2,y2,boxtype,fore,back : byte);
  5823.   const
  5824.     corners : array[1..4,0..3] of char = (
  5825.       (#218,#214,#213,#201),   { top left corner        }
  5826.       (#191,#184,#183,#187),   { top right corner       }
  5827.       (#192,#211,#212,#200),   { bottom left    }
  5828.       (#217,#189,#190,#188)    { bottom right   }
  5829.     );
  5830.  
  5831.     lines : array[1..2,0..1] of char = (
  5832.       (#196,#205),                 { horizontal         }
  5833.       (#179,#186)
  5834.     );                             { vertical           }
  5835.  
  5836.  
  5837.   var
  5838.     boxcorner     : array[1..4] of char;
  5839.     boxline       : array[1..4] of char;
  5840.     boxchar       : char;
  5841.     horchars      : byte;
  5842.     verchars      : byte;
  5843.     i             : word;
  5844.     cursoron      : boolean;
  5845.     x,y,xtop,xbot : byte;
  5846.  
  5847.   begin
  5848.     if (boxtype > 15) then begin
  5849.       boxchar := chr(boxtype);
  5850.       fillchar(boxcorner,4,boxchar);
  5851.       fillchar(boxline,4,boxchar)
  5852.     end else begin
  5853.       boxcorner[1] := corners[1,(boxtype and 3)];
  5854.       boxcorner[2] := corners[2,((boxtype shr 1) and 3)];
  5855.       boxcorner[3] := corners[3,
  5856.           ((boxtype and 1) or ( 2 * ((boxtype shr 3) and 1)))];
  5857.       boxcorner[4] := corners[4,((boxtype shr 2) and 3)];
  5858.       boxline[1]   := lines[1,((boxtype shr 1) and 1)];
  5859.       boxline[2]   := lines[1,((boxtype shr 3) and 1)];
  5860.       boxline[3]   := lines[2,(boxtype and 1)];
  5861.       boxline[4]   := lines[2,((boxtype shr 2) and 1)]
  5862.     end;
  5863.     horchars := x2 - x1 - 1; verchars := y2 - y1 - 1;
  5864.     __write(x1, y1, fore, back, boxcorner[1]);
  5865.     if (horchars > 0) then __write(x1 + 1, y1, fore, back, __rep(horchars, boxline[1]));
  5866.     __write(x2, y1, fore, back, boxcorner[2]);
  5867.     for i := 1 to verchars do begin
  5868.       __write(x1, y1 + i, fore, back, boxline[3]);
  5869.       __write(x2, y1 + i, fore, back, boxline[4])
  5870.     end;
  5871.     __write(x1, y2, fore, back, boxcorner[3]);
  5872.     if (horchars > 0) then __write(
  5873.       x1 + 1, y2, fore,back, __rep(horchars, boxline[2])
  5874.     );
  5875.     __write(x2, y2, fore, back, boxcorner[4]);
  5876.   end;   { __boxscn }
  5877.  
  5878.  
  5879.  
  5880.  
  5881.   procedure __write(col, row, f, b: byte; st: str80);
  5882.   begin
  5883.     __scn(col, row, at(f, b), st);
  5884.   end;
  5885.  
  5886.  
  5887.   procedure __hwrite(x, y, f, b, h: byte; st: string);
  5888.   var
  5889.     c, i,n  :    byte;
  5890.     on      : boolean;
  5891.  
  5892.   begin
  5893.     i := 1; n := 0; c := f; on := false;
  5894.     while i <= length(st) do begin
  5895.       if st[i] = '~' then begin
  5896.         inc(n); on := not on; if on then c := h else c := f
  5897.       end else __write(x+i-1-n, y, c, b, st[i]);
  5898.       inc(i)
  5899.     end;
  5900.   end;
  5901.  
  5902.  
  5903.  
  5904.   { error = 255: debugging mode; else no debuginfo display }
  5905.   function __barcheck(s: string; var error: byte): boolean;
  5906.   var
  5907.     bad      : boolean;
  5908.     i, j, k,
  5909.     len      :    byte;
  5910.     onepart  :  string;
  5911.  
  5912.   begin
  5913.     j := 1; len := length(s); error := 1; i := 1;
  5914.     bad := (pos(' ', s) = 0) or (__cvtstr(s, _rem_white_str) = '');
  5915.     if error = 255 then writeln(s);
  5916.     if not bad then repeat
  5917.       while (s[j] = ' ') and (j < len) do inc(j); i := j;
  5918.       while (s[j] <> ' ') and (j < len) do inc(j);
  5919.       bad := false;
  5920.       onepart := __cvtstr(copy(s, i, j-i), _rem_white_str);
  5921.       if onepart <> '' then begin
  5922.         for k := 1 to 26 do begin { IS er een hoofdletter? }
  5923.           bad := bad or (pos(chr(k+64), onepart) > 0);
  5924.         end;
  5925.         bad := not bad;
  5926.       end;
  5927.       if error = 255 then writeln(i:2,' ', j:2,  ' "', onepart, '"');
  5928.     until bad or (j >= len);
  5929.     error := i;
  5930.     __barcheck := not bad;
  5931.   end;
  5932.  
  5933.  
  5934.  
  5935.   function  __barchoice(x,x1,y,f,b,h : byte; st: string; timeout: byte): byte;
  5936.   const
  5937.     quit: boolean = false;
  5938.  
  5939.   var
  5940.     key           :   word;
  5941.     off,i,j, find :   byte;
  5942.     s             : string;
  5943.  
  5944.     procedure hilite;
  5945.     var i : byte;
  5946.     begin
  5947.       __attrib(x+off, y, x+length(st)-1+off, y, f, b);
  5948.       for i := 1 to length(st) do
  5949.         if ((st[i]=upcase(st[i])) and (upcase(st[i]) in ['A'..'Z'])) then
  5950.           __attrib(x+i-1+off, y, x+i-1+off, y, h, b);
  5951.       i := 1;
  5952.       while st[i]<>s[find] do inc(i);
  5953.       if pos(' ', copy(st, 2, length(st)-2)) <> 0 then begin
  5954.         while st[i]<>' ' do dec(i);
  5955.         j := i-1; inc(i);
  5956.         while st[i]<>' ' do inc(i); dec(i);
  5957.         __attrib(j+x+off, y, i+x+off, y, b, f)
  5958.       end else __attrib(i+x-1+off, y, i+x-1+off, y, b, f);
  5959.     end;
  5960.  
  5961.   begin
  5962.     s := ''; find := 1; quit := false;
  5963.     off := ((x1-x) - length(st)) div 2;
  5964.     for i := 1 to length(st) do begin
  5965.       if (st[i]=upcase(st[i])) and (upcase(st[i]) in ['A'..'Z']) then
  5966.         s := s + st[i];
  5967.       if st[i] <> '_' then __write(x+i-1+off, y, f, b, st[i]);
  5968.     end;
  5969.     repeat
  5970.       hilite;
  5971.       key := __retdelaykey(timeout, _enter);
  5972.       if (key = _left) or (key = _padleft) then begin
  5973.         if find>1 then dec(find) else find := length(s)
  5974.       end else if (key = _right) or (key = _padright) then begin
  5975.         if find<length(s) then inc(find) else find := 1
  5976.       end else if (key = _enter) or (key = _padenter) then begin
  5977.         quit := true
  5978.       end else if (key = _esc) then begin
  5979.         quit := true; find := 0
  5980.       end else if key = _space then begin
  5981.         if find < length(s) then inc(find) else find := 1
  5982.       end else for i := 1 to length(s) do if s[i] = upcase(lastkey) then begin
  5983.         find := i; quit := true
  5984.       end;
  5985.     until quit;
  5986.     if find > 0 then hilite;
  5987.     __barchoice := find;
  5988.   end;
  5989.  
  5990.  
  5991.  
  5992.   procedure __setblwin(blinkon : boolean);
  5993.   var reg : registers;
  5994.   begin
  5995.     if ((_curdevice = _egaadapter) or (_curdevice = _vgaadapter)) then begin
  5996.       with reg do begin
  5997.         ah := $10;
  5998.         al := $03;
  5999.         bl := byte(blinkon);
  6000.         intr($10, reg)
  6001.       end
  6002.     end else begin
  6003.       port[$3b8] := 8; mem[0:$465] := port[$3b8];
  6004.       if blinkon then port[$3b8] := $28;
  6005.     end;
  6006.   end;
  6007.  
  6008.  
  6009.  
  6010.  
  6011.   procedure __resscn(sc: _scnimageptr);
  6012.   begin
  6013.     __movescn(1, 1, _curcolumns, _currows, sc, true)
  6014.   end;
  6015.  
  6016.  
  6017.  
  6018.   procedure __savscn(sc: _scnimageptr);
  6019.   begin
  6020.     __movescn(1, 1, _curcolumns, _currows, sc, false)
  6021.   end;
  6022.  
  6023.  
  6024.  
  6025.   procedure __copyscn(x1, y1, x2, y2, x, y: byte);
  6026.   var buffer: _scnimage;
  6027.   begin
  6028.     __movescn(x1, y1, x2, y2, @buffer, false);
  6029.     __movescn(x, y, x+x2-x1, y+y2-y1, @buffer, true);
  6030.   end;
  6031.  
  6032.  
  6033.  
  6034.   procedure __attrib(x1, y1, x2, y2, f, b: byte);
  6035.   var i: byte;
  6036.   begin
  6037.     for i := y1 to y2 do changeattr(x1, i, at(f, b), succ(x2-x1))
  6038.   end;
  6039.  
  6040.  
  6041.  
  6042.   procedure __bandwin(del: boolean; x1, y1, x2, y2, f, b, shadow, bt: byte);
  6043.   var
  6044.     br, ht,
  6045.     vt, mih,
  6046.     ff, bb,
  6047.     miv      : byte;
  6048.  
  6049.   begin
  6050.     if del then begin
  6051.       miv := y1 + (y2-y1) div 2; mih := x1 + (x2-x1) div 2;
  6052.       if y2-y1>5 then vt := 2 else vt := 1;
  6053.       if x2-x1>20 then ht := 5 else ht := 3;
  6054.       __clrscn(mih - ht, miv - vt + 1, mih + ht, miv + vt, f, b, ' ');
  6055.       __boxscn(mih - ht, miv - vt + 1, mih + ht, miv + vt, 15, f, b);
  6056.       __delay(100);
  6057.     end;
  6058.     if bt=1 then br := 00 else br := 15;
  6059.     __loc(x1-1, y2+3, ff, bb);
  6060.     if shadow = sh_high then begin
  6061.       if bb = black then shadow := lightgray else shadow := white
  6062.     end;
  6063.     if shadow = sh_low then shadow := lightgray;
  6064.     if shadow = sh_default then begin
  6065.       if bb = black then shadow := darkgray else shadow := black
  6066.     end;
  6067.     if _currows = 25 then begin
  6068.       __attrib(x1-1, y2+3, x2+5, y2+3, lightgray, shadow);
  6069.       __attrib(x2+2, y1-1, x2+5, y2+2, lightgray, shadow);
  6070.       __clrscn(x1-3, y1-2, x2+3, y2+2, f, b, ' ');
  6071.     end else begin
  6072.       __attrib(x1-1, y2+3, x2+3, y2+3, lightgray, shadow);
  6073.       __attrib(x2+3, y1-1, x2+3, y2+2, lightgray, shadow);
  6074.       __clrscn(x1-2, y1-2, x2+2, y2+2, f, b, ' ');
  6075.     end;
  6076.     __boxscn(x1-1, y1-1, x2+1, y2+1, br, f, b);
  6077.   end;
  6078.  
  6079.  
  6080.   procedure __vert(x, y, f, b: byte; s: string);
  6081.   var i: byte;
  6082.   begin
  6083.     for i := 1 to length(s) do __write(x, y + i - 1, f, b, s[i]);
  6084.   end;
  6085.  
  6086.  
  6087.   procedure __betwscn(x1, x2, y, f, b: byte; st: string);
  6088.   var x : integer;
  6089.  
  6090.   begin
  6091.     if length(st) >= x2 - x1 + 1 then __write(x1, y, f, b, st) else begin
  6092.       x := x1 + (x2 - x1 + 1 - length(st)) div 2;
  6093.       __write(x, y, f, b, st);
  6094.     end;
  6095.   end;
  6096.  
  6097.  
  6098.   procedure __clrscn(x1, y1, x2, y2, f, b: byte; c: char);
  6099.   var
  6100.     y      : integer;
  6101.  
  6102.   begin
  6103.     if x2 > 80 then x2 := 80;
  6104.     for y := y1 to y2 do __write(x1, y, f, b, __rep(x2-x1+1, c));
  6105.   end;
  6106.  
  6107.  
  6108.  
  6109.   procedure __cls;
  6110.   begin
  6111.     __clrscn(1, 1, _curcolumns, _currows, 7, 0, ' ');
  6112.   end;
  6113.  
  6114.  
  6115.  
  6116.  
  6117.   procedure __equipscn;
  6118.   const
  6119.     active     = 1;                    
  6120.     alternate  = 2;                    
  6121.  
  6122.   var
  6123.     savecursor : word;
  6124.     crtport    : word;
  6125.     adisplay   : byte;
  6126.     i          : integer;
  6127.     regs       : registers;
  6128.  
  6129.  
  6130.   begin 
  6131.     _monoadapter    := _unknown;       
  6132.     _coloradapter   := _unknown;
  6133.     _egaadapter     := _unknown;
  6134.     _hercadapter    := _unknown;
  6135.     _vgaadapter     := _unknown;
  6136.     _mcgaadapter    := _unknown;
  6137.     egamonitor_     := _nomonitor;     
  6138.     analogmonitor_  := _nomonitor;
  6139.     egamemory_      := 0;
  6140.     with regs do begin
  6141.       ax := $1a00;
  6142.       bx := $0000;
  6143.       intr($10,regs);
  6144.       inline($fb);                   
  6145.       if (al = $1a) then begin
  6146.         _monoadapter  := _absent;
  6147.         _coloradapter := _absent;
  6148.         _egaadapter   := _absent;
  6149.         _hercadapter  := _absent;
  6150.         _mcgaadapter  := _absent;
  6151.         _vgaadapter   := _absent;
  6152.         adisplay := bl;
  6153.         for i := active to alternate do begin
  6154.           case adisplay of
  6155.             $01     : _monoadapter  := _mono;
  6156.             $02     : _coloradapter := _color;
  6157.             $04     : _egaadapter   := _color;
  6158.             $05     : _egaadapter   := _mono;
  6159.             $07,$08 : if (adisplay = bl) then
  6160.                          _vgaadapter := active
  6161.                       else
  6162.                          _vgaadapter := alternate;
  6163.             $0b,$0c : _mcgaadapter  := _color;
  6164.           end; 
  6165.           case adisplay of
  6166.             $07,$0b : analogmonitor_ := _anmonomonitor;
  6167.             $08,$0c : analogmonitor_ := _ancolormonitor;
  6168.           end; 
  6169.           adisplay := bh        
  6170.         end;
  6171.       end else begin
  6172.         _mcgaadapter  := _absent;
  6173.         _vgaadapter   := _absent
  6174.       end;
  6175.       ax := $1200;
  6176.       bx := $ff10;
  6177.       cx := $00ff;
  6178.       intr($10,regs);
  6179.       inline($fb);                   
  6180.       if (_egaadapter = _unknown) then begin
  6181.         if ((cl < 12) and (bh <= 1) and (bl <= 3)) then begin                  
  6182.           if (bh = 1) then begin             
  6183.             _monoadapter  := _absent;
  6184.             _egaadapter   := _mono;
  6185.             egamonitor_   := _monomonitor
  6186.           end else begin             
  6187.             _coloradapter := _absent;
  6188.             _egaadapter   := _color
  6189.           end
  6190.         end else _egaadapter := _absent 
  6191.       end;
  6192.       if (_egaadapter <> _absent) then begin
  6193.         egamemory_ := 64 + (64 * bl);  
  6194.         if (((cx and $0009) = 9) or ((cx and $0003) = 3)) then
  6195.           egamonitor_ := _enhancedmonitor else
  6196.             if (egamonitor_ <> _monomonitor) then egamonitor_ := _colormonitor
  6197.       end
  6198.     end;
  6199.  
  6200.     if (_monoadapter = _unknown) then begin                           
  6201.       crtport           := $3b4;    
  6202.       port[crtport]     := $f;      
  6203.       savecursor        := port[crtport + 1];   
  6204.       port[crtport + 1] := 90;      
  6205.       if (port[crtport + 1] = 90) then _monoadapter   := _mono else
  6206.         _monoadapter   := _absent;
  6207.       port[crtport + 1] := savecursor
  6208.     end;
  6209.  
  6210.     if (_coloradapter = _unknown) then begin                           
  6211.       crtport           := $3d4;    
  6212.       port[crtport]     := $f;      
  6213.       savecursor        := port[crtport + 1];   
  6214.       port[crtport + 1] := 90;      
  6215.       if (port[crtport + 1] = 90) then _coloradapter  := _color else
  6216.         _coloradapter  := _absent;
  6217.       port[crtport + 1] := savecursor
  6218.     end;
  6219.  
  6220.     if (_vgaadapter > _absent) then with regs do begin
  6221.       ax := $0f00;                
  6222.       intr($10,regs);
  6223.       if (_vgaadapter = active) then 
  6224.         if ((al = 7) or (al = 15)) then _vgaadapter := _mono else
  6225.          _vgaadapter := _color else if ((al = 7) or (al = 15)) then
  6226.            _vgaadapter := _color else _vgaadapter := _mono
  6227.     end;
  6228.   end;  
  6229.  
  6230.  
  6231.  
  6232.  
  6233.   {$F+}
  6234.   function __retdvscn(
  6235.     var dvmode    : byte;
  6236.     var dvcols    : word;
  6237.     var dvrows    : word;
  6238.     var dbactpage : byte;
  6239.     var dvdispage : byte
  6240.   ): byte;
  6241.   var
  6242.     reg         : registers;
  6243.     charheight  :      word;
  6244.  
  6245.   begin
  6246.     with reg do begin
  6247.       fillchar(reg, sizeof(reg), $00);
  6248.       ax := $0F00;
  6249.       intr($10, reg);
  6250.       dvmode := al; dvcols := ah; dbactpage := bh
  6251.     end;
  6252.     if (dvmode = 7) then begin
  6253.       _curdevice := _mono;
  6254.       _scnloc    := ptr($b000,$0000)
  6255.     end else if (dvmode < 13) then begin
  6256.       _curdevice := _color;
  6257.       _scnloc    := ptr($b000,$8000)
  6258.     end else begin
  6259.       if (dvmode = 15) then _curdevice := _mono else _curdevice := _color;
  6260.       _scnloc := ptr($a000,$0000)
  6261.     end;
  6262.     with reg do begin
  6263.       es := _vectoraddr(_scnloc)._seg;
  6264.       di := _vectoraddr(_scnloc)._ofs;
  6265.       ah := $fe;
  6266.       intr($10,reg);
  6267.       inline($fb);
  6268.       _scnloc := ptr(es,di)
  6269.     end;
  6270.     if ((_curdevice = _hercadapter) or (_curdevice = _monoadapter)) then begin
  6271.       _curmonitor := _monomonitor;
  6272.       charheight  := 14
  6273.     end else if (_curdevice = _coloradapter) then begin
  6274.       _curmonitor := _colormonitor;
  6275.       charheight  := 8
  6276.     end else if (
  6277.       _curdevice = _egaadapter
  6278.     ) then _curmonitor := egamonitor_ else if (
  6279.       (_curdevice = _vgaadapter) or
  6280.       (_curdevice = _mcgaadapter)
  6281.     ) then _curmonitor := analogmonitor_ else _curmonitor := _nomonitor;
  6282.     if (
  6283.       (_egaadapter = _curdevice) or (_mcgaadapter = _curdevice) or
  6284.       (_vgaadapter = _curdevice)
  6285.     ) then with reg do begin
  6286.       ax := $1130;
  6287.       bx := 0;
  6288.       intr($10,reg);
  6289.       dvrows := dl + 1;
  6290.       charheight := cx
  6291.     end else dvrows := 25;
  6292.     case dvmode of
  6293.       4..6,8..10,17..19: _maxdisplaypage := 0;
  6294.       0,1: if (dvrows = 50) then _maxdisplaypage := 6 else _maxdisplaypage := 7;
  6295.       2,3,7: begin
  6296.         if (_curdevice = _mono) then _maxdisplaypage := 0 else
  6297.           _maxdisplaypage := 3;
  6298.         if (_curdevice = _vgaadapter) then case dvrows of
  6299.           25    : _maxdisplaypage := 7;
  6300.           43,50 : _maxdisplaypage := 3
  6301.         end;
  6302.         if (_curdevice = _egaadapter) then begin
  6303.           if (egamemory_ > 64) then _maxdisplaypage := 7 else
  6304.             _maxdisplaypage := 3;
  6305.           if (dvrows = 43) then _maxdisplaypage := _maxdisplaypage div 2
  6306.         end
  6307.       end;
  6308.       13: begin
  6309.         _maxdisplaypage := 7;
  6310.         if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
  6311.           _maxdisplaypage := 1 else if (egamemory_ = 128) then
  6312.           _maxdisplaypage := 3;
  6313.       end;
  6314.       14: begin
  6315.         _maxdisplaypage := 3;
  6316.         if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
  6317.           _maxdisplaypage := 0 else if (egamemory_ = 128) then
  6318.           _maxdisplaypage := 1
  6319.       end;
  6320.       15..16: begin
  6321.         _maxdisplaypage := 1;
  6322.         if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
  6323.           _maxdisplaypage := 0;
  6324.       end;
  6325.     end;
  6326.  
  6327.     dvdispage    := _curdisplaypage;
  6328.     _curmode       := dvmode;
  6329.     _currows       := dvrows;
  6330.     _curcolumns    := dvcols;
  6331.     _curactivepage := dbactpage;
  6332.     maxscanline_   := charheight - 1;
  6333.     __retdvscn     := _curdevice
  6334.   end;
  6335.   {$F-}
  6336.  
  6337.  
  6338.   procedure __stdio;
  6339.   begin
  6340.     assign(input, ''); reset(input);
  6341.     assign(output, ''); rewrite(output);
  6342.   end;
  6343.  
  6344.  
  6345.  
  6346.  
  6347.   procedure newbuffer(var t :textbuffer);
  6348.   begin
  6349.     t.first := nil;
  6350.     t.last := nil;
  6351.   end; {newbuffer}
  6352.  
  6353.  
  6354.   procedure deletebuffer(var t :textbuffer);
  6355.   var step,temp :textnodeptr;
  6356.   begin
  6357.     step := t.first;
  6358.     while (step <> nil) do begin
  6359.       freemem(step^.line,length(step^.line^)+1);
  6360.       temp := step;
  6361.       step := step^.next;
  6362.       dispose(temp);
  6363.     end; {while}
  6364.     newbuffer(t);
  6365.   end; {deletebuffer}
  6366.  
  6367.  
  6368.   function emptybuffer(var t :textbuffer) :boolean;
  6369.   begin
  6370.     emptybuffer := (t.first = nil);
  6371.   end; {emptybuffer}
  6372.  
  6373.  
  6374.   function firstline(var t :textbuffer) :textnodeptr;
  6375.   begin
  6376.     firstline := t.first;
  6377.   end; {firstline}
  6378.  
  6379.  
  6380.   function lastline(var t :textbuffer) :textnodeptr;
  6381.   begin
  6382.     lastline := t.last;
  6383.   end; {lastline}
  6384.  
  6385.  
  6386.   function nextline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;
  6387.   begin
  6388.     nextline := nil;
  6389.     if (pos = nil) then exit;
  6390.     nextline := pos^.next;
  6391.   end; {nextline}
  6392.  
  6393.  
  6394.   function prevline(var t :textbuffer;  pos :textnodeptr) :textnodeptr;
  6395.   begin
  6396.     prevline := nil;
  6397.     if (pos = nil) then exit;
  6398.     prevline := pos^.prev;
  6399.   end; {prevline}
  6400.  
  6401.  
  6402.   function deleteline(var t :textbuffer;  var pos :textnodeptr) :textnodeptr;
  6403.   begin
  6404.     deleteline := nextline(t,pos);
  6405.     if (pos=nil) or emptybuffer(t) then exit;
  6406.     if (pos^.prev <> nil) then pos^.prev^.next := pos^.next;
  6407.     if (pos^.next <> nil) then pos^.next^.prev := pos^.prev;
  6408.     if (pos = t.first) then t.first := pos^.next; {pos was first node}
  6409.     if (pos = t.last) then t.last := pos^.prev;   {pos was last node}
  6410.     if (pos^.line <> nil) then freemem(pos^.line,length(pos^.line^)+1);
  6411.                                                     {free existing line}
  6412.     dispose(pos); pos := nil;
  6413.   end;
  6414.  
  6415.  
  6416.   function newnode(line :string) :textnodeptr;
  6417.   var temp :textnodeptr;
  6418.   begin
  6419.     newnode := nil;
  6420.     new(temp);
  6421.     if (temp=nil) then exit;
  6422.     temp^.next := nil;
  6423.     temp^.prev := nil;
  6424.     getmem(temp^.line,length(line)+1);
  6425.     if (temp^.line = nil) then exit;
  6426.     temp^.line^ := line;
  6427.     newnode := temp;
  6428.   end; {newnode}
  6429.  
  6430.  
  6431.   procedure modifytextline(var t: textbuffer; pos: textnodeptr; line: string);
  6432.   begin
  6433.     if pos = nil then exit;
  6434.     if (pos^.line <> nil) then freemem(pos^.line, length(pos^.line^)+1);
  6435.     getmem(pos^.line,length(line)+1); { space for new line }
  6436.     if (pos^.line = nil) then exit;
  6437.     pos^.line^ := line;
  6438.   end; {modifytextline}
  6439.  
  6440.  
  6441.   function gettextline(var t: textbuffer;  pos :textnodeptr) :string;
  6442.   begin
  6443.     gettextline := '';
  6444.     if pos=nil then exit;
  6445.     gettextline := pos^.line^;
  6446.   end; {gettextline}
  6447.  
  6448.  
  6449.   procedure addtoend(var t :textbuffer;  line :string);
  6450.   var temp :textnodeptr;
  6451.   begin
  6452.     temp := newnode(line);
  6453.     if (temp=nil) then exit;
  6454.  
  6455.     if (t.first = nil) then begin
  6456.       t.first := temp;
  6457.       t.last := t.first;
  6458.     end else begin
  6459.       t.last^.next := temp;
  6460.       temp^.prev := t.last;
  6461.       t.last := temp;
  6462.     end; {else}
  6463.   end; {addtoend}
  6464.  
  6465.  
  6466.   procedure addinsert(var t :textbuffer;  pos :textnodeptr;  line :string);
  6467.   var temp :textnodeptr;
  6468.   begin
  6469.     if (emptybuffer(t) or (pos = nil)) then begin
  6470.       addtoend(t,line);
  6471.     end else begin
  6472.       temp := newnode(line);
  6473.       if (temp=nil) then exit;
  6474.  
  6475.       if (pos^.prev <> nil) then
  6476.         pos^.prev^.next := temp;
  6477.       temp^.next := pos;
  6478.       temp^.prev := pos^.prev;
  6479.       pos^.prev := temp;
  6480.  
  6481.       if (pos = t.first) then   {new front}
  6482.         t.first := temp;
  6483.     end; {else}
  6484.   end; {addinsert}
  6485.  
  6486.  
  6487.   function bufferlength(var t :textbuffer) :word;
  6488.   var
  6489.     count :word;
  6490.     step :textnodeptr;
  6491.   begin
  6492.     count := 0;
  6493.     step := t.first;
  6494.     while (step <> nil) do begin
  6495.       step := step^.next;
  6496.       inc(count);
  6497.     end; {while}
  6498.  
  6499.     bufferlength := count;
  6500.   end; {bufferlength}
  6501.  
  6502.   {- Create a new, wrapped, buffer.  Margin must be reasonable, i.e. not too
  6503.    close to 0 or 255 -}
  6504.  
  6505.  
  6506.   procedure wrapbuffer(var t: textbuffer; margin: byte);
  6507.   const seperators = [#32..#47,#58..#64,#91..#96,#123..#126];
  6508.   var
  6509.     w      :  textbuffer;
  6510.     tmpst,
  6511.     line   :      string;
  6512.     source :        word; {can't be Byte, Length may be 255}
  6513.     step   : textnodeptr;
  6514.     ch     :        char;
  6515.  
  6516.  
  6517.     procedure finishline;
  6518.     begin
  6519.       addtoend(w, line);
  6520.       line := '';
  6521.     end; {finishline}
  6522.  
  6523.   
  6524.     procedure addchar(ch: char);
  6525.     var
  6526.       overflow : string;
  6527.       p        :   byte;
  6528.  
  6529.     begin
  6530.       if (length(line) >= margin) then begin  {break the line}
  6531.         overflow := '';
  6532.           {first remove excess spaces}
  6533.         if (line[length(line)]=' ') then
  6534.           while (length(line) > 1) and (line[length(line)-1]=' ') do
  6535.             dec(line[0]);     {drop last space}
  6536.  
  6537.         if (length(line) >= margin) then begin
  6538.           p := length(line);
  6539.           while (p > 0) and not (line[p] in seperators) do
  6540.             dec(p);       {look backwards for seperator}
  6541.  
  6542.           if (p=0) then p := margin;    {no seperator, one huge word}
  6543.  
  6544.           overflow := copy(line,p+1,length(line)-p);
  6545.           line[0] := char(p);
  6546.         end; {if}
  6547.  
  6548.         finishline;
  6549.         line := overflow+ch;
  6550.       end else begin
  6551.         line := line+ch;
  6552.       end; {else}
  6553.     end; {addchar}
  6554.   
  6555.  
  6556.     procedure tab;
  6557.     var count: byte;
  6558.     begin
  6559.       for count := 1 to 8 - (pred(length(line)) mod 8) do addchar(' ');
  6560.     end; {tab}
  6561.  
  6562.  
  6563.   begin
  6564.     newbuffer(w);
  6565.     step := t.first; line := '';
  6566.     while (step <> nil) do begin
  6567.       source := 1;
  6568.       tmpst := step^.line^;
  6569.       while (source <= length(tmpst)) and (step <> nil) do begin
  6570.         ch := tmpst[source];
  6571.         case ch of
  6572.           ^m : begin
  6573.             line := line+^m^j;
  6574.             finishline;
  6575.           end;
  6576.           ^i : tab;
  6577.           ^j,#141 : {ignore lf and soft-cr};
  6578.           else addchar(ch);
  6579.         end; {case}
  6580.         inc(source);
  6581.       end; {while}
  6582.       step := step^.next;
  6583.     end; {while}
  6584.     if (line <> '') then finishline;
  6585.     deletebuffer(t);
  6586.     t := w;
  6587.   end; {wrapbuffer}
  6588.  
  6589.  
  6590.   {- Create a new, unwrapped, buffer.  All the lines except the last one
  6591.    in the new buffer will be of length 255 -}
  6592.  
  6593.  
  6594.   procedure unwrapbuffer(var t,w :textbuffer);
  6595.   var
  6596.     line :string;
  6597.     source :word; {can't be Byte, Length may be 255}
  6598.     step :textnodeptr;
  6599.  
  6600.  
  6601.     procedure finishline;
  6602.     begin
  6603.       addtoend(w,line);
  6604.       line := '';
  6605.     end; {finishline}
  6606.  
  6607.  
  6608.     procedure addchar(ch :char);
  6609.     begin
  6610.       if (length(line) = 255) then finishline;
  6611.       line := line+ch;
  6612.     end; {addchar}
  6613.  
  6614.  
  6615.   begin
  6616.     newbuffer(w); step := t.first; line := '';
  6617.     while (step <> nil) do begin
  6618.       for source := 1 to length(step^.line^) do addchar(step^.line^[source]);
  6619.       step := step^.next;
  6620.     end; {while}
  6621.     if (line <> '') then finishline;
  6622.   end; {unwrapbuffer}
  6623.   { quickbbs message text, credits to p.j. muller }
  6624.  
  6625.  
  6626.  
  6627.  
  6628.   function  __crc32(value: byte; crc: longint) : longint;
  6629.   const
  6630.     crc32_table : array[0..255] of longint = (
  6631.       $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f,
  6632.       $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988,
  6633.       $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, $1db71064, $6ab020f2,
  6634.       $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
  6635.       $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
  6636.       $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, $a2677172,
  6637.       $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
  6638.       $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
  6639.       $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423,
  6640.       $cfba9599, $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
  6641.       $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, $01db7106,
  6642.       $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
  6643.       $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d,
  6644.       $91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
  6645.       $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
  6646.       $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
  6647.       $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7,
  6648.       $a4d1c46d, $d3d6f4fb, $4369e96a, $346ed9fc, $ad678846, $da60b8d0,
  6649.       $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa,
  6650.       $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
  6651.       $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
  6652.       $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a,
  6653.       $ead54739, $9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84,
  6654.       $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
  6655.       $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
  6656.       $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, $67dd4acc,
  6657.       $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8, $a1d1937e,
  6658.       $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
  6659.       $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55,
  6660.       $316e8eef, $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
  6661.       $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, $b2bd0b28,
  6662.       $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
  6663.       $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f,
  6664.       $72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38,
  6665.       $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
  6666.       $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
  6667.       $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69,
  6668.       $616bffd3, $166ccf45, $a00ae278, $d70dd2ee, $4e048354, $3903b3c2,
  6669.       $a7672661, $d06016f7, $4969474d, $3e6e77db, $aed16a4a, $d9d65adc,
  6670.       $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
  6671.       $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693,
  6672.       $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
  6673.       $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
  6674.     );
  6675.  
  6676.   begin
  6677.     if crc = 0 then crc := $ffffffff; { must be set high to start with }
  6678.     __crc32 := crc32_table[byte(crc xor longint(value))] xor
  6679.       ((crc shr 8) and $00ffffff);
  6680.   end;
  6681.  
  6682.  
  6683.  
  6684.   function  __crc16(value : byte; crc : word): word;
  6685.   (* crctab calculated by mark g. mendel, network systems corporation *)
  6686.   const
  6687.     crc16_table : array[0..255] of word = (
  6688.        $0000,  $1021,  $2042,  $3063,  $4084,  $50a5,  $60c6,  $70e7,
  6689.        $8108,  $9129,  $a14a,  $b16b,  $c18c,  $d1ad,  $e1ce,  $f1ef,
  6690.        $1231,  $0210,  $3273,  $2252,  $52b5,  $4294,  $72f7,  $62d6,
  6691.        $9339,  $8318,  $b37b,  $a35a,  $d3bd,  $c39c,  $f3ff,  $e3de,
  6692.        $2462,  $3443,  $0420,  $1401,  $64e6,  $74c7,  $44a4,  $5485,
  6693.        $a56a,  $b54b,  $8528,  $9509,  $e5ee,  $f5cf,  $c5ac,  $d58d,
  6694.        $3653,  $2672,  $1611,  $0630,  $76d7,  $66f6,  $5695,  $46b4,
  6695.        $b75b,  $a77a,  $9719,  $8738,  $f7df,  $e7fe,  $d79d,  $c7bc,
  6696.        $48c4,  $58e5,  $6886,  $78a7,  $0840,  $1861,  $2802,  $3823,
  6697.        $c9cc,  $d9ed,  $e98e,  $f9af,  $8948,  $9969,  $a90a,  $b92b,
  6698.        $5af5,  $4ad4,  $7ab7,  $6a96,  $1a71,  $0a50,  $3a33,  $2a12,
  6699.        $dbfd,  $cbdc,  $fbbf,  $eb9e,  $9b79,  $8b58,  $bb3b,  $ab1a,
  6700.        $6ca6,  $7c87,  $4ce4,  $5cc5,  $2c22,  $3c03,  $0c60,  $1c41,
  6701.        $edae,  $fd8f,  $cdec,  $ddcd,  $ad2a,  $bd0b,  $8d68,  $9d49,
  6702.        $7e97,  $6eb6,  $5ed5,  $4ef4,  $3e13,  $2e32,  $1e51,  $0e70,
  6703.        $ff9f,  $efbe,  $dfdd,  $cffc,  $bf1b,  $af3a,  $9f59,  $8f78,
  6704.        $9188,  $81a9,  $b1ca,  $a1eb,  $d10c,  $c12d,  $f14e,  $e16f,
  6705.        $1080,  $00a1,  $30c2,  $20e3,  $5004,  $4025,  $7046,  $6067,
  6706.        $83b9,  $9398,  $a3fb,  $b3da,  $c33d,  $d31c,  $e37f,  $f35e,
  6707.        $02b1,  $1290,  $22f3,  $32d2,  $4235,  $5214,  $6277,  $7256,
  6708.        $b5ea,  $a5cb,  $95a8,  $8589,  $f56e,  $e54f,  $d52c,  $c50d,
  6709.        $34e2,  $24c3,  $14a0,  $0481,  $7466,  $6447,  $5424,  $4405,
  6710.        $a7db,  $b7fa,  $8799,  $97b8,  $e75f,  $f77e,  $c71d,  $d73c,
  6711.        $26d3,  $36f2,  $0691,  $16b0,  $6657,  $7676,  $4615,  $5634,
  6712.        $d94c,  $c96d,  $f90e,  $e92f,  $99c8,  $89e9,  $b98a,  $a9ab,
  6713.        $5844,  $4865,  $7806,  $6827,  $18c0,  $08e1,  $3882,  $28a3,
  6714.        $cb7d,  $db5c,  $eb3f,  $fb1e,  $8bf9,  $9bd8,  $abbb,  $bb9a,
  6715.        $4a75,  $5a54,  $6a37,  $7a16,  $0af1,  $1ad0,  $2ab3,  $3a92,
  6716.        $fd2e,  $ed0f,  $dd6c,  $cd4d,  $bdaa,  $ad8b,  $9de8,  $8dc9,
  6717.        $7c26,  $6c07,  $5c64,  $4c45,  $3ca2,  $2c83,  $1ce0,  $0cc1,
  6718.        $ef1f,  $ff3e,  $cf5d,  $df7c,  $af9b,  $bfba,  $8fd9,  $9ff8,
  6719.        $6e17,  $7e36,  $4e55,  $5e74,  $2e93,  $3eb2,  $0ed1,  $1ef0
  6720.      );
  6721.  
  6722.   begin
  6723.     __crc16 := crc16_table[((crc shr 8) and 255)] xor
  6724.       (crc shl 8) xor value;
  6725.   end;
  6726.  
  6727.  
  6728.  
  6729.  
  6730.  
  6731.  
  6732.  
  6733.  
  6734.  
  6735.  
  6736.  
  6737.  
  6738.  
  6739.   procedure setselerror__(error : word);
  6740.   begin
  6741.     _selerror := error;
  6742.   end;
  6743.  
  6744.  
  6745.  
  6746.  
  6747.   function itemads__(pickptr : _pickptr; itemno : word) : pointer;
  6748.   begin
  6749.     with pickptr^ do begin
  6750.       if (_pointers) then
  6751.         itemads__ := pointer(
  6752.           pointer(longint(_itemaddr) +
  6753.           (pred(itemno) * sizeof(pointer)))^
  6754.         ) else itemads__ := pointer(
  6755.            longint(_itemaddr) + (pred(itemno) * _itemsize)
  6756.         );
  6757.     end;
  6758.   end;
  6759.  
  6760.   
  6761.   
  6762.   procedure uptwnsel__(pickptr : _pickptr);
  6763.   var itemno : word;
  6764.   begin
  6765.     with pickptr^ do begin
  6766.       for itemno := _firstpage to _lastpage do __itemsel(
  6767.         pickptr, _fore, _back, itemno
  6768.       );
  6769.     end;
  6770.   end;
  6771.  
  6772.  
  6773.  
  6774.   procedure __itemsel(pickptr: _pickptr; fore, back: byte; itemno: word);
  6775.   const blank = #32;
  6776.   var
  6777.     x, y, z  : word;
  6778.     dspstr : string;
  6779.  
  6780.   begin
  6781.     with pickptr^ do begin
  6782.       _curitemptr := itemads__(pickptr, itemno);
  6783.       fillchar(dspstr, sizeof(dspstr), blank);
  6784.       z := length(string(_curitemptr^));
  6785.       if (z > _itemlen) then z := _itemlen;
  6786.       move(string(_curitemptr^)[1], dspstr, z);
  6787.       z := (itemno - _firstpage);
  6788.       x := succ(((z mod _numcols) * (_itemlen + _spacing)) + _spacing);
  6789.       y := succ(z div _numcols);
  6790.       __write(_x1+x-1, _y1+y-1, fore, back, 
  6791.         __juststr(string(_curitemptr^), ' ', _x2 - _x1 - 1, _center_str)
  6792.       );
  6793.     end;
  6794.   end;
  6795.  
  6796.  
  6797.  
  6798.  
  6799.   function  __makesel(
  6800.     x1, y1,
  6801.     x2, y2,
  6802.     fore, back,
  6803.     barfore, 
  6804.     barback    :    byte;
  6805.     keyproc    : pointer;
  6806.     itemlen    :    word;
  6807.     numitems   :    word;
  6808.     itemsize   :    word;
  6809.     numcols    :    word;
  6810.     spacing    :    word;
  6811.     itemaddr   : pointer;
  6812.     ispointers : boolean
  6813.   ) : _pickptr;
  6814.  
  6815.   var
  6816.     pickptr    : _pickptr;
  6817.  
  6818.   begin
  6819.     _fore := fore; _back := back;
  6820.     _x1 := x1; _y1 := y1; _x2 := x2; _y2 := y2;
  6821.     getmem(pickptr, sizeof(_pick));
  6822.     with pickptr^ do begin
  6823.       fillchar(pickptr^, sizeof(_pick), 0);
  6824.       _barfore := barfore; _barback := barback;
  6825.       _keyproc := keyproc; _numitems := numitems;
  6826.       _itemlen := itemlen;
  6827.       if (ispointers) then _itemsize := sizeof(pointer) else
  6828.         _itemsize := itemsize + 1;
  6829.       _numcols := numcols; _spacing := spacing; _itemaddr := itemaddr;
  6830.       _pointers := ispointers; _curitemnum := 1;
  6831.     end;
  6832.     __makesel := pickptr;
  6833.   end;
  6834.  
  6835.  
  6836.  
  6837.   function  __picksel(
  6838.     listpickptr : _pickptr;
  6839.     var retitem :   string;
  6840.     var retkey  :     word
  6841.   ) : word;
  6842.   type strpointer = ^string;
  6843.   var
  6844.     pageitems  :    word;
  6845.     found      : boolean;
  6846.     initkey    : boolean;
  6847.     return     : boolean;
  6848.     key        :    word;
  6849.  
  6850.  
  6851.     procedure redraw(up: boolean; start, stop : word);
  6852.     begin
  6853.       with listpickptr^ do begin
  6854.         if up then __copyscn(_x1, _y1+1, _x2, _y2, _x1, _y1) else
  6855.           __copyscn(_x1, _y1, _x2, _y2-1, _x1, _y1+1);
  6856.         while (start <= stop) do begin
  6857.           __itemsel(listpickptr, _fore, _back, start);
  6858.           inc(start)
  6859.         end;
  6860.       end;
  6861.     end;
  6862.  
  6863.  
  6864.     procedure movebar;
  6865.     var
  6866.       flag    : boolean;
  6867.       hold    : word;
  6868.  
  6869.     begin
  6870.       with listpickptr^ do begin
  6871.         __itemsel(listpickptr, _fore, _back, _curitemnum);
  6872.         case key of
  6873.           _up, _padup : if (_curitemnum > _numcols) then begin
  6874.             dec(_curitemnum, _numcols);
  6875.             if (_curitemnum < _firstpage) then begin
  6876.               dec(_firstpage, _numcols);
  6877.               _lastpage := pred(_firstpage + pageitems);
  6878.               redraw(false, _firstpage, pred(_firstpage + _numcols));
  6879.             end;
  6880.           end;
  6881.  
  6882.           _down, _paddown : if (_curitemnum < _numitems) then begin
  6883.             flag := false;
  6884.             if (_curitemnum + _numcols <= _numitems) then begin
  6885.               inc(_curitemnum, _numcols);
  6886.               flag := true;
  6887.             end;
  6888.             if (
  6889.               (
  6890.                 (_lastpage < _numitems) and (_curitemnum > _lastpage)
  6891.               )
  6892.               or
  6893.               (
  6894.                 ((_curitemnum + _numcols) > _numitems) and
  6895.                 (_curitemnum < _numitems) and
  6896.                 (_lastpage < _numitems) and
  6897.                 (not flag)
  6898.               )
  6899.             ) then begin
  6900.               inc(_firstpage, _numcols); inc(_lastpage, _numcols);
  6901.               if (_lastpage > _numitems) then _lastpage := _numitems;
  6902.               redraw(true, succ(_lastpage - _numcols), _lastpage);
  6903.             end;
  6904.           end;
  6905.  
  6906.           _right, _padright : if (_curitemnum < _numitems) then begin
  6907.             inc(_curitemnum);
  6908.             if (_curitemnum > _lastpage) then begin
  6909.               inc(_firstpage, _numcols); inc(_lastpage, _numcols);
  6910.               if (_lastpage > _numitems) then _lastpage := _numitems;
  6911.               redraw(true, _curitemnum, _lastpage);
  6912.             end;
  6913.           end;
  6914.  
  6915.           _left, _padleft : if (_curitemnum > 1) then begin
  6916.             dec(_curitemnum);
  6917.             if (_curitemnum < _firstpage) then begin
  6918.               dec(_firstpage, _numcols);
  6919.               _lastpage := pred(_firstpage + pageitems);
  6920.               redraw(false, succ(_curitemnum - _numcols), _curitemnum);
  6921.             end;
  6922.           end;
  6923.  
  6924.           _home, _padhome : if (_curitemnum > 1) then begin
  6925.             _curitemnum := 1; _firstpage := 1; _lastpage := pageitems;
  6926.             if (_lastpage > _numitems) then _lastpage := _numitems;
  6927.             uptwnsel__(listpickptr);
  6928.           end;
  6929.  
  6930.           _end, _padend : if (_curitemnum <> _numitems) then begin
  6931.             _curitemnum := _numitems;
  6932.             if (_numitems > pageitems) then begin
  6933.               __copyscn(_x1, _y1+1, _x2, _y2, _x1, _y1);
  6934.               _lastpage  := _curitemnum;
  6935.               _firstpage := {succ}(
  6936.                 _curitemnum - (
  6937.                   pageitems - (
  6938.                     _numcols - (
  6939.                       _curitemnum mod _numcols
  6940.                     )
  6941.                   )
  6942.                 )
  6943.               );
  6944.               uptwnsel__(listpickptr);
  6945.             end;
  6946.           end;
  6947.  
  6948.           _pgup, _padpgup : if (_firstpage > 1) then begin
  6949.             hold := _curitemnum - _firstpage;
  6950.             if (_firstpage < pageitems) then _firstpage := 1 else
  6951.                dec(_firstpage, pageitems - _numcols);
  6952.             _lastpage := pred(_firstpage + pageitems);
  6953.             _curitemnum := _firstpage + hold;
  6954.             uptwnsel__(listpickptr);
  6955.           end;
  6956.  
  6957.           _pgdn, _padpgdn : if (_lastpage < _numitems) then begin
  6958.             hold := _curitemnum - _firstpage;
  6959.             __copyscn(_x1, _y1+1, _x2, _y2, _x1, _y1);
  6960.             inc(_lastpage, pageitems - _numcols);
  6961.             if (_lastpage > _numitems) then begin
  6962.               _lastpage  := _numitems;
  6963.               _firstpage := succ(
  6964.                 _lastpage - (
  6965.                   pageitems - (
  6966.                     _numcols - (
  6967.                       _lastpage mod _numcols
  6968.                     )
  6969.                   )
  6970.                 )
  6971.               );
  6972.               _curitemnum := _firstpage + hold;
  6973.               if (_curitemnum > _numitems) then _curitemnum := _numitems;
  6974.             end else begin
  6975.               inc(_firstpage, pageitems - _numcols);
  6976.               _curitemnum := _firstpage + hold;
  6977.             end;
  6978.             uptwnsel__(listpickptr);
  6979.           end;
  6980.         end; { case }
  6981.         __itemsel(listpickptr, _barfore, _barback, _curitemnum);
  6982.       end;
  6983.     end;
  6984.  
  6985.  
  6986.  
  6987.   begin
  6988.     __picksel := 0; retitem := '';
  6989.     with listpickptr^ do begin
  6990.       pageitems := (_numcols * (_y2 - _y1 + 1));
  6991.       if (pageitems > _numitems) then pageitems := _numitems;
  6992.       if (_firstpage = 0) then _firstpage := _curitemnum;
  6993.       if (_lastpage = 0) then _lastpage  := pageitems;
  6994.       uptwnsel__(listpickptr);
  6995.       __itemsel(listpickptr, _barfore, _barback, _curitemnum);
  6996.       initkey := false; return := false;
  6997.       repeat
  6998.         key := __retkey;
  6999.         retitem := strpointer(_curitemptr)^; found := false; movebar;
  7000.         if (key=_enter) or (key=_padenter) or (key=_esc) then return := true;
  7001.         if (key = _esc) then begin retitem := ''; _curitemnum := 0 end;
  7002.         __picksel := _curitemnum;
  7003.       until (return);
  7004.     end;
  7005.     {
  7006.     if (_selerror = _noerror_sel) then begin
  7007.       with listpickptr^ do __itemsel(listpickptr, _fore, _back, _curitemnum);
  7008.     end;
  7009.     }
  7010.   end;
  7011.  
  7012.  
  7013.  
  7014.  
  7015.   function  __zapsel(var pickptr : _pickptr) : boolean;
  7016.   begin
  7017.     __zapsel := false;
  7018.     freemem(pickptr, sizeof(_pick));
  7019.     pickptr  := nil;
  7020.     __zapsel := true;
  7021.   end;
  7022.  
  7023.  
  7024.  
  7025.  
  7026.  
  7027.  
  7028.  
  7029.  
  7030.   function __editline(var st: string; control: _editctrl): boolean;
  7031.   const
  7032.     insmode : boolean = true;
  7033.     insstrs : array[boolean] of string[3] = ('Ovr', 'Ins');
  7034.  
  7035.   var
  7036.     typekey    : char;
  7037.     strlen,
  7038.     edtlen     : byte;
  7039.     _cur, key  : word;
  7040.  
  7041.   begin
  7042.     _cur := 1;
  7043.     with control do begin
  7044.       strlen := __min(length(st), _vscncols);
  7045.       edtlen := _viewx2 - _viewx1 + 1;
  7046.       fillchar(st[strlen+1], abs(sizeof(st) - _vscncols+1), ' ');
  7047.       __write(
  7048.         _viewx1, _viewy1, _vscnfore, _vscnback,
  7049.         __rep(_viewx2 - _viewx1, ' ')
  7050.       );
  7051.       repeat
  7052.  
  7053.         if _cur <= edtlen then begin
  7054.           gotoxy(_viewx1 + _cur - 1, _viewy1);
  7055.           __write(
  7056.             _viewx1, _viewy1, _vscnfore, _vscnback, copy(st + ' ', 1, edtlen-1)
  7057.           )
  7058.         end else begin
  7059.           gotoxy(_viewx2, _viewy1);
  7060.           __write(
  7061.             _viewx1, _viewy1, _vscnfore, _vscnback,
  7062.             copy(st + ' ', (_cur - edtlen + 1), edtlen-1)
  7063.           );
  7064.         end;
  7065.  
  7066.         if _showflags then begin
  7067.           __write(_viewx1, _viewy1-1, _vscnfore, _vscnback, insstrs[insmode]);
  7068.           if _cur = 1 then __write(
  7069.             _viewx2-3, _viewy1-1, _vscnfore, _vscnback, 'Beg'
  7070.           ) else if _cur >= strlen then __write(
  7071.             _viewx2-3, _viewy1-1, _vscnfore, _vscnback, 'End'
  7072.           ) else __write(
  7073.             _viewx2-3, _viewy1-1, _vscnfore, _vscnback, '   '
  7074.           )
  7075.         end;
  7076.  
  7077.         key := __retkey; typekey := chr(lo(key));
  7078.         if not(
  7079.           (key = _esc) or (key = _padenter) or (key = _enter)
  7080.         ) then case key of
  7081.           _left, _padleft : if _cur > 1 then dec(_cur);
  7082.           _right, _padright : if (
  7083.             (_cur <= strlen) and (_cur < _vscncols)
  7084.           ) then inc(_cur);
  7085.           _home, _padhome: _cur := 1;
  7086.           _end, _padend: _cur := __min(strlen + 1, _vscncols);
  7087.           _del, _paddel : if _cur <= strlen then begin
  7088.             delete(st, _cur, 1); st[strlen] := ' '; dec(strlen);
  7089.             if (_cur > 1) and (_cur > strlen + 1) then dec(_cur);
  7090.           end;
  7091.           _ins, _padins : insmode := not insmode;
  7092.           _backspace : if _cur > 1 then begin
  7093.             if _cur > 1 then dec(_cur); delete(st, _cur, 1); dec(strlen);
  7094.           end;
  7095.           else if (
  7096.             (upcase(typekey) in [#32..#126]) and (_cur <= _vscncols)
  7097.           ) then begin
  7098.             if insmode then begin
  7099.               if strlen < _vscncols then begin
  7100.                 if _cur <= strlen then insert(typekey, st, _cur) else begin
  7101.                   st := st + typekey;
  7102.                 end;
  7103.                 inc(strlen); 
  7104.                 if _cur < _vscncols then inc(_cur);
  7105.               end;
  7106.             end else begin
  7107.               if _cur <= strlen then st[_cur] := typekey else
  7108.                 if _cur <= _vscncols then begin 
  7109.                   st := st + typekey;
  7110.                   inc(strlen);
  7111.                 end;
  7112.               if _cur < _vscncols then inc(_cur)
  7113.             end;
  7114.           end;
  7115.         end;
  7116.       until (key = _esc) or (key = _padenter) or (key = _enter);
  7117.     end;
  7118.     __editline := (key <> _esc);
  7119.   end;
  7120.  
  7121.  
  7122.  
  7123.  
  7124.  
  7125.  
  7126.   procedure __totalmem;
  7127.   var reg : registers;
  7128.   begin
  7129.     with reg do begin
  7130.       intr($12, reg);
  7131.       dosmemory := ax;
  7132.       if true then begin
  7133.         ax := $8800;
  7134.         intr($15, reg);
  7135.         extmemory := ax
  7136.       end else extmemory := 0
  7137.     end
  7138.   end;
  7139.  
  7140.  
  7141.  
  7142.  
  7143.  
  7144.   procedure __availmem;
  7145.   const
  7146.     copyoff = $12;
  7147.     adsoff  = $2c;
  7148.  
  7149.   var
  7150.     vdiskptr     : pointer;
  7151.     copynotice   : string[5];
  7152.     temp         : longint;
  7153.     reg          : registers;
  7154.     firstmemptr  : pointer;
  7155.     deviceofs    : word;
  7156.     deviceptr    : pointer;
  7157.  
  7158.   begin
  7159.     with reg do begin
  7160.       ah := $48;
  7161.       bx := $ffff;
  7162.       intr($21, reg);
  7163.       dosmemory := bx shr 6;
  7164.       if (dosmemory > 0) then begin
  7165.         ah := $48;
  7166.         intr($21, reg);
  7167.         memptr := ptr(ax, 0);
  7168.         es     := ax;
  7169.         ah     := $49;
  7170.         intr($21, reg)
  7171.       end else memptr := nil;
  7172.       if false  then begin
  7173.         extads._hibyte := 0;
  7174.         extads._loword := 0;
  7175.         extmemory      := 0
  7176.       end else begin
  7177.         ah := $88;
  7178.         intr($15, reg);
  7179.         extmemory := ax;
  7180.         ah := $52;
  7181.         intr($21, reg);
  7182.         firstmemptr := ptr(memw[es:bx - 2] + 1, 0);
  7183.         if (_dosmajorver = 2) then deviceofs := $17 else
  7184.           if (
  7185.             (_dosminorver = 0) and (_dosmajorver = 3)
  7186.           ) then deviceofs := $28 else deviceofs := $22;
  7187.         deviceptr := pointer(meml[es:bx + deviceofs]);
  7188.         with extads do begin
  7189.           _hibyte := $10;
  7190.           _loword := 0
  7191.         end;
  7192.         temp := 0;
  7193.         while (__ptr2lsup(deviceptr) >= __ptr2lsup(firstmemptr)) do begin
  7194.           vdiskptr := ptr(_vectoraddr(deviceptr)._seg, $12);
  7195.           move(vdiskptr^, copynotice[1], 5);
  7196.           copynotice[0] := char(5);
  7197.           if (copynotice = 'VDISK') then begin
  7198.             vdiskptr := ptr(_vectoraddr(deviceptr)._seg, $2c);
  7199.             move(vdiskptr^, extads, 3);
  7200.             with extads do temp := (
  7201.               (
  7202.                 (longint(_loword) + 1023) div 1024) +
  7203.                 64 * longint(_hibyte - $10
  7204.               )
  7205.             );
  7206.           end;
  7207.           deviceptr := pointer(deviceptr^)
  7208.         end;
  7209.         dec(extmemory, word(temp));
  7210.         if (extmemory = 0) then fillchar(extads, sizeof(_xads), 0)
  7211.       end
  7212.     end
  7213.   end;
  7214.  
  7215.  
  7216.  
  7217.  
  7218.  
  7219.  
  7220.  
  7221.  
  7222.  
  7223.  
  7224.  
  7225.  
  7226.  
  7227.  
  7228.   procedure __allocmem;
  7229.   var reg : registers;
  7230.   begin
  7231.     with reg do begin
  7232.       ah := $48;
  7233.       bx := blockreq;
  7234.       intr($21, reg);
  7235.       if ((flags and fcarry) <> 0) then begin
  7236.         errorcode := ax;
  7237.         if (ax = 8) then allocsize := bx else allocsize := 0;
  7238.         memptr := nil
  7239.       end else begin
  7240.         allocsize := blockreq;
  7241.         memptr    := ptr(ax, 0);
  7242.         errorcode := 0
  7243.       end
  7244.     end
  7245.   end;
  7246.  
  7247.  
  7248.  
  7249.  
  7250.  
  7251.   procedure __freemem;
  7252.   var reg : registers;
  7253.   begin
  7254.     with reg do begin
  7255.       ah := $49;
  7256.       es := _vectoraddr(memptr)._seg;
  7257.       intr($21, reg);
  7258.       if ((flags and fcarry) <> 0) then errorcode := ax else errorcode := 0
  7259.     end
  7260.   end;
  7261.  
  7262.  
  7263.  
  7264.  
  7265.  
  7266.  
  7267.   procedure __altermem;
  7268.   var reg : registers;
  7269.   begin
  7270.     with reg do begin
  7271.       ah := $4a;
  7272.       bx := blockreq;
  7273.       es := _vectoraddr(memptr)._seg;
  7274.       intr($21, reg);
  7275.       if ((flags and fcarry) <> 0) then begin
  7276.         errorcode := ax;
  7277.         if (ax = 8) then altersize := bx else altersize := 0
  7278.       end else begin
  7279.         altersize := blockreq;
  7280.         errorcode := 0
  7281.       end
  7282.     end
  7283.   end;
  7284.  
  7285.  
  7286.  
  7287.  
  7288.  
  7289.   function __firstmem : pointer;
  7290.   var reg : registers;
  7291.   begin
  7292.     with reg do begin
  7293.       ah := $52;
  7294.       intr($21, reg);
  7295.       __firstmem := ptr(memw[es:bx - 2] + 1, 0)
  7296.     end
  7297.   end;
  7298.  
  7299.  
  7300.  
  7301.  
  7302.  
  7303.  
  7304.   function __ctrlmem;
  7305.   var blockptr : ^_memctrl;
  7306.   begin
  7307.     blockptr := ptr(_vectoraddr(memptr)._seg - 1, _vectoraddr(memptr)._ofs);
  7308.     with blockptr^ do if ((_header <> 'M') and (_header <> 'Z')) then begin
  7309.       __ctrlmem := nil;
  7310.       fillchar(memblock, sizeof(_memctrl), #0)
  7311.     end else begin
  7312.       move(blockptr^, memblock, sizeof(_memctrl));
  7313.       if (_header = 'Z') then __ctrlmem := nil else
  7314.         __ctrlmem := ptr(_vectoraddr(blockptr)._seg + _size + 2, 0)
  7315.     end
  7316.   end;
  7317.  
  7318.  
  7319.  
  7320.  
  7321.  
  7322.   procedure __hookmem;
  7323.   var
  7324.     vectortable : array[0..255] of pointer absolute 0:0;
  7325.     i           : integer;
  7326.     found       : boolean;
  7327.     nextptr     : pointer;
  7328.     thisptr     : pointer;
  7329.     progblock   : _memctrl;
  7330.     beginaddr   : longint;
  7331.     endaddr     : longint;
  7332.     thisaddr    : longint;
  7333.  
  7334.   begin
  7335.     thisptr := ptr(progseg, 0);
  7336.     nextptr := __ctrlmem(thisptr, progblock);
  7337.     with progblock do begin
  7338.       if (_header = #0) then begin
  7339.         hookvecno := -1;
  7340.         exit
  7341.       end;
  7342.       beginaddr := __ptr2lsup(thisptr);
  7343.       endaddr   := beginaddr + (16 * longint(_size));
  7344.     end;
  7345.     i := hookvecno; found := false;
  7346.     if ((i < 0) or (i > 255)) then begin hookvecno := -1; exit end;
  7347.     while ((i <= 255) and (not found)) do begin
  7348.       thisaddr := __ptr2lsup(vectortable[i]);
  7349.       if (
  7350.         (beginaddr <= thisaddr) and (thisaddr <= endaddr)
  7351.       ) then found := true else begin
  7352.         inc(i);
  7353.         if (i = $30) then inc(i, 2)
  7354.       end
  7355.     end;
  7356.     if (found) then hookvecno := i else hookvecno := -1
  7357.   end;
  7358.  
  7359.  
  7360.  
  7361.  
  7362.  
  7363.   procedure __xtmovmem;
  7364.   type
  7365.     localdesctable = record
  7366.       seglimit   : word;
  7367.       loword     : word;
  7368.       hibyte     : byte;
  7369.       dataaccess : byte;
  7370.       reserved   : word
  7371.     end;
  7372.  
  7373.     globaldesctable = record
  7374.       dummy      : localdesctable;
  7375.       local      : localdesctable;
  7376.       source     : localdesctable;
  7377.       target     : localdesctable;
  7378.       bioscs     : localdesctable;
  7379.       stack      : localdesctable
  7380.     end;
  7381.  
  7382.   var
  7383.     gdt     : globaldesctable;
  7384.     dosads  : _xads;
  7385.     reg     : registers;
  7386.     tempseg : word;
  7387.     tempofs : word;
  7388.     temp    : longint;
  7389.  
  7390.   begin
  7391.     if false then begin errorcode := 4; exit end;
  7392.     fillchar(gdt, sizeof(gdt), #0);
  7393.     tempseg := _vectoraddr(memptr)._seg;
  7394.     tempofs := _vectoraddr(memptr)._ofs;
  7395.     temp    := (16 * longint(tempseg)) + longint(tempofs);
  7396.     with dosads do begin
  7397.       _hibyte := byte((temp div 65536) and $ff);
  7398.       _loword := word((temp - (65536 * longint(_hibyte))) and $ffff)
  7399.     end;
  7400.  
  7401.     with gdt do begin
  7402.       if (toext) then begin
  7403.         source.hibyte := dosads._hibyte;
  7404.         source.loword := dosads._loword;
  7405.         target.hibyte := extads._hibyte;
  7406.         target.loword := extads._loword
  7407.       end else begin
  7408.         source.hibyte := extads._hibyte;
  7409.         source.loword := extads._loword;
  7410.         target.hibyte := dosads._hibyte;
  7411.         target.loword := dosads._loword
  7412.       end;
  7413.       source.seglimit   := nowords shl 2;
  7414.       target.seglimit   := nowords shl 2;
  7415.       source.dataaccess := $93;
  7416.       target.dataaccess := $93
  7417.     end;
  7418.     with reg do begin
  7419.       ax := $8700;
  7420.       cx := nowords;
  7421.       es := seg(gdt);
  7422.       si := ofs(gdt);
  7423.       intr($15, reg);
  7424.       if ((flags and fcarry) <> 0) then errorcode := ah else errorcode := 0
  7425.     end
  7426.   end;
  7427.  
  7428.  
  7429.  
  7430.  
  7431.  
  7432.  
  7433.  
  7434.  
  7435.   procedure errorexit;
  7436.   begin
  7437.     exitproc  := prevexitproc_;
  7438.     erroraddr := calleraddr_;
  7439.     inline($fb)
  7440.   end;
  7441.  
  7442.  
  7443.   
  7444.  
  7445.  
  7446.  
  7447.  
  7448.   {$F+}
  7449.   function __fetchmem; external;
  7450.   {$F-}
  7451.  
  7452.  
  7453.  
  7454.  
  7455.  
  7456.  
  7457. { sort management }
  7458. const
  7459.   comparesrt_  : pointer = nil;      
  7460.   iosrt_       : pointer = nil;      
  7461.   recsizesrt_  : word    = 0;        
  7462.   maxrecsrt_   : word    = 0;        
  7463.   lastrecsrt_  : word    = 0;        
  7464.   curpossrt_   : longint = 0;        
  7465.   sortdatasrt_ : boolean = false;    
  7466.   inmemorysrt_ : boolean = false;    
  7467.   variablesrt_ : boolean = false;    
  7468.   insortsrt_   : boolean = false;    
  7469.  
  7470.  
  7471.  
  7472.  
  7473.   function calllesssrt__(var data1, data2): boolean;
  7474.   inline($ff/$1e/comparesrt_);
  7475.  
  7476.  
  7477.   procedure calliosrt__;
  7478.   inline($ff/$1e/iosrt_);
  7479.  
  7480.   {$F+}
  7481.   function  ritemsrt__(
  7482.     p: pointer; itemsize: word; itemnum: word
  7483.   ): pointer; external;
  7484.   {$L RITEMSRT}
  7485.  
  7486.  
  7487.  
  7488.   procedure __isortsrt;
  7489.   var
  7490.     i, j       : word;
  7491.     insertptr : pointer;
  7492.  
  7493.   begin 
  7494.     _numsortedsrt := 0;
  7495.     if (numrecords = 0) then exit;                           
  7496.     comparesrt_ := lessfunction;
  7497.     getmem(insertptr, recordsize);
  7498.     if (insertptr = nil) then exit;
  7499.     for i := 1 to (numrecords - 1) do begin
  7500.       j := i - 1;
  7501.       move(ritemsrt__(dataptr, recordsize, i)^, insertptr^, recordsize);
  7502.       while (
  7503.         (j < i) and
  7504.         calllesssrt__(insertptr^, ritemsrt__(dataptr, recordsize, j)^)
  7505.       ) do begin
  7506.         move(
  7507.           ritemsrt__(dataptr, recordsize, j)^, 
  7508.           ritemsrt__(dataptr, recordsize, j + 1)^, 
  7509.           recordsize
  7510.         );
  7511.         dec(j)
  7512.       end;
  7513.       move(insertptr^, ritemsrt__(dataptr, recordsize, j + 1)^, recordsize);
  7514.     end;
  7515.     _numsortedsrt := numrecords;
  7516.     freemem(insertptr, recordsize);
  7517.   end;  
  7518.  
  7519.  
  7520.  
  7521.  
  7522.   procedure __qsortsrt;
  7523.   const stack_max = 16;
  7524.   type
  7525.     stacksize = 1..stack_max;
  7526.     partition = record
  7527.       lower : word;
  7528.       upper : word
  7529.     end;
  7530.  
  7531.   var
  7532.     parstack      : array[stacksize] of partition;
  7533.     parstacktop   : word;
  7534.     lindex, rindex : word;
  7535.     i, j           : word;
  7536.     lparsize      : word;
  7537.     rparsize      : word;
  7538.     parsize       : word;
  7539.     pivotdataptr  : pointer;
  7540.     tempdataptr   : pointer;
  7541.     tempptr1      : pointer;
  7542.     tempptr2      : pointer;
  7543.  
  7544.   begin 
  7545.     if (numrecords <= _useinsertsrt) then begin
  7546.       __isortsrt(dataptr, numrecords, recordsize, lessfunction);
  7547.       exit
  7548.     end;
  7549.     comparesrt_   := lessfunction;
  7550.     _numsortedsrt := 0;
  7551.  
  7552.     getmem(pivotdataptr, recordsize);
  7553.     if (pivotdataptr = nil) then exit;
  7554.     getmem(tempdataptr, recordsize);
  7555.     if (tempdataptr = nil) then begin
  7556.       freemem(pivotdataptr, recordsize);
  7557.       exit
  7558.     end;
  7559.  
  7560.     parstacktop := 1;
  7561.     with parstack[1] do begin
  7562.       lower := 0;
  7563.       upper := numrecords - 1;
  7564.     end;
  7565.  
  7566.     repeat
  7567.       with parstack[parstacktop] do begin
  7568.         lindex := lower;
  7569.         rindex := upper
  7570.       end;
  7571.       dec(parstacktop);
  7572.  
  7573.       repeat
  7574.         i := lindex;
  7575.         j := rindex;
  7576.         move(
  7577.           ritemsrt__(dataptr, recordsize, (lindex + rindex) div 2)^, 
  7578.           pivotdataptr^, recordsize
  7579.         );
  7580.  
  7581.         repeat
  7582.           while calllesssrt__(
  7583.             ritemsrt__(dataptr, recordsize, i)^, 
  7584.             pivotdataptr^
  7585.           ) do inc(i);
  7586.           while calllesssrt__(
  7587.             pivotdataptr^, 
  7588.             ritemsrt__(dataptr, recordsize, j)^
  7589.           ) do dec(j);
  7590.           if (i <= j) then begin
  7591.             tempptr1 := ritemsrt__(dataptr, recordsize, i);
  7592.             tempptr2 := ritemsrt__(dataptr, recordsize, j);
  7593.             move(tempptr2^, tempdataptr^, recordsize);
  7594.             move(tempptr1^, tempptr2^, recordsize);
  7595.             move(tempdataptr^, tempptr1^, recordsize);
  7596.             inc(i);
  7597.             dec(j)
  7598.           end
  7599.         until (i > j);
  7600.  
  7601.         rparsize := rindex - i;
  7602.         lparsize := j - lindex;
  7603.         if (rparsize = 0) then rindex := j else
  7604.           if (lparsize = 0) then lindex := i else 
  7605.             if (rparsize > lparsize) then begin                       
  7606.               if (rparsize <= _useinsertsrt) then __isortsrt(
  7607.                 ritemsrt__(dataptr, recordsize, i), 
  7608.                 rparsize + 1, recordsize, lessfunction
  7609.               ) else begin                  
  7610.                 inc(parstacktop);
  7611.                 with parstack[parstacktop] do begin
  7612.                   lower := i;
  7613.                   upper := rindex
  7614.                 end
  7615.               end;
  7616.               rindex := j
  7617.             end else begin
  7618.               if (lparsize <= _useinsertsrt) then __isortsrt(
  7619.                 ritemsrt__(dataptr, recordsize, lindex), 
  7620.                 lparsize + 1, recordsize, lessfunction
  7621.               ) else begin                  
  7622.                 inc(parstacktop);
  7623.                 with parstack[parstacktop] do begin
  7624.                   lower := lindex;
  7625.                   upper := j
  7626.                 end
  7627.               end;
  7628.               lindex := i
  7629.             end;
  7630.         parsize := rindex - lindex
  7631.       until (parsize <= _useinsertsrt);
  7632.       if (parsize > 0) then __isortsrt(
  7633.         ritemsrt__(dataptr, recordsize, lindex), 
  7634.         parsize + 1, recordsize, lessfunction
  7635.       )
  7636.     until (parstacktop = 0);
  7637.     _numsortedsrt := numrecords;
  7638.     freemem(pivotdataptr, recordsize);
  7639.     freemem(tempdataptr, recordsize)
  7640.   end;  
  7641.  
  7642.  
  7643.  
  7644.     
  7645.     
  7646.   
  7647.   procedure __addsrt;
  7648.   var
  7649.     tempdataptr : pointer;
  7650.     recordsize  : word;
  7651.  
  7652.   begin 
  7653.     if ((dataptr = nil) or (not insortsrt_)) then begin
  7654.       errorcode := 2;               
  7655.       exit                          
  7656.     end else errorcode := 0;
  7657.  
  7658.     if ((not variablesrt_) and (lastrecsrt_ > maxrecsrt_)) then begin
  7659.       errorcode := 1;
  7660.       exit
  7661.     end;
  7662.  
  7663.     if (not inmemorysrt_) then begin
  7664.       tempdataptr := _datasrt;
  7665.       __iptrsup(tempdataptr, curpossrt_);
  7666.       if (not variablesrt_) then recordsize := recsizesrt_ else begin
  7667.         recordsize := byte(dataptr^);
  7668.         inc(recordsize);
  7669.         if ((curpossrt_ + recordsize) > _datasizesrt) then begin
  7670.           errorcode := 1;
  7671.           exit
  7672.         end
  7673.       end;
  7674.       move(dataptr^, tempdataptr^, recsizesrt_);
  7675.       inc(curpossrt_, recordsize)
  7676.     end else tempdataptr := dataptr;
  7677.     if (not sortdatasrt_) then move(
  7678.       tempdataptr, ritemsrt__(_ptrsrt, sizeof(pointer), lastrecsrt_)^, 
  7679.       sizeof(pointer)
  7680.     );
  7681.     inc(lastrecsrt_)                   
  7682.   end;  
  7683.  
  7684.  
  7685.  
  7686.   
  7687.   procedure __retsrt;
  7688.   begin 
  7689.     if (not insortsrt_) then begin
  7690.       errorcode := 2;               
  7691.       exit                          
  7692.     end else errorcode := 0;
  7693.     if (lastrecsrt_ >= _numsortedsrt) then begin
  7694.       errorcode := 1;               
  7695.       exit
  7696.     end;
  7697.  
  7698.     if (not sortdatasrt_) then dataptr := pointer(
  7699.       ritemsrt__(_ptrsrt, sizeof(pointer), lastrecsrt_)^
  7700.     ) else dataptr := ritemsrt__(_datasrt, recsizesrt_, lastrecsrt_);
  7701.     inc(lastrecsrt_)
  7702.   end;  
  7703.  
  7704.  
  7705.  
  7706.   
  7707.   procedure __sortsrt;
  7708.   var
  7709.     tempptr : pointer;
  7710.     tempsrt : word;
  7711.  
  7712.   begin 
  7713.     _numsortedsrt := 0;
  7714.     errorcode     := 0;
  7715.     if ((_datasrt <> nil) and (_datasizesrt <> 0)) then
  7716.       freemem(_datasrt, _datasizesrt);
  7717.     if ((_ptrsrt <> nil) and (_ptrsizesrt <> 0)) then
  7718.       freemem(_ptrsrt, _ptrsizesrt);
  7719.     recsizesrt_  := recordsize;
  7720.     maxrecsrt_   := maxrecords - 1;
  7721.     lastrecsrt_  := 0;
  7722.     curpossrt_   := 0;
  7723.     variablesrt_ := ((sortcontrol and _variable_srt) <> 0);
  7724.     inmemorysrt_ := ((sortcontrol and _inmemory_srt) <> 0);
  7725.     sortdatasrt_ := (
  7726.       (
  7727.         ((sortcontrol and _sortdata_srt) <> 0) or
  7728.         (recordsize <= 4)
  7729.       ) and
  7730.       (not inmemorysrt_) and (not variablesrt_) 
  7731.     );
  7732.  
  7733.     if (sortdatasrt_) then begin
  7734.       _ptrsrt      := nil;
  7735.       _ptrsizesrt  := 0
  7736.     end else begin
  7737.       _ptrsizesrt  := sizeof(pointer) * longint(maxrecords);
  7738.       getmem(_ptrsrt, _ptrsizesrt);
  7739.       if (_ptrsrt = nil) then begin errorcode := 1; exit end
  7740.     end;
  7741.  
  7742.     if (inmemorysrt_) then begin
  7743.       _datasrt     := nil;
  7744.       _datasizesrt := 0
  7745.     end else begin
  7746.       _datasizesrt := recordsize * longint(maxrecords);
  7747.       getmem(_datasrt, _datasizesrt);
  7748.       if (_datasrt = nil) then begin
  7749.         _datasizesrt := maxavail - (3 * recordsize);
  7750.         maxrecsrt_   := _datasizesrt div recordsize;
  7751.         getmem(_datasrt, _datasizesrt);
  7752.         if (_datasrt = nil) then begin errorcode := 1; exit end
  7753.       end
  7754.     end;
  7755.  
  7756.     insortsrt_ := true;
  7757.     if (inputproc <> nil) then begin
  7758.       iosrt_ := inputproc;
  7759.       calliosrt__
  7760.     end else begin
  7761.       errorcode  := 2;
  7762.       insortsrt_ := false;
  7763.       exit
  7764.     end;
  7765.  
  7766.     if ((_datasrt <> nil) and (curpossrt_ < _datasizesrt)) then begin
  7767.       tempptr := _datasrt;
  7768.       tempsrt := curpossrt_ mod 8;
  7769.       if (tempsrt <> 0) then curpossrt_ := curpossrt_ + (8 - tempsrt);
  7770.       __iptrsup(tempptr, curpossrt_);
  7771.       freemem(tempptr, _datasizesrt - curpossrt_);
  7772.       _datasizesrt := curpossrt_
  7773.     end;
  7774.     if ((_ptrsrt <> nil) and (lastrecsrt_ < maxrecords)) then begin
  7775.       tempptr     := _ptrsrt;
  7776.       _ptrsizesrt := longint(lastrecsrt_) * sizeof(pointer);
  7777.       tempsrt := _ptrsizesrt mod 8;
  7778.       if (tempsrt <> 0) then _ptrsizesrt := _ptrsizesrt + (8 - tempsrt);
  7779.       __iptrsup(tempptr, _ptrsizesrt);
  7780.       freemem(tempptr, (longint(maxrecords) * sizeof(pointer)) - _ptrsizesrt)
  7781.     end;
  7782.  
  7783.     if (sortdatasrt_) then __qsortsrt(
  7784.       _datasrt, lastrecsrt_, recsizesrt_, lessfunction
  7785.     ) else __qsortsrt(_ptrsrt, lastrecsrt_, sizeof(pointer), lessfunction);
  7786.  
  7787.     if (outputproc <> nil) then begin
  7788.       lastrecsrt_ := 0;
  7789.       iosrt_      := outputproc;
  7790.       calliosrt__
  7791.     end;
  7792.     insortsrt_ := false;
  7793.  
  7794.     if ((sortcontrol and _leavemem_srt) = 0) then begin
  7795.       if ((_datasrt <> nil) and (_datasizesrt <> 0)) then freemem(
  7796.         _datasrt, _datasizesrt
  7797.       );
  7798.       if ((_ptrsrt <> nil) and (_ptrsizesrt <> 0)) then freemem(
  7799.         _ptrsrt, _ptrsizesrt
  7800.       );
  7801.       _ptrsrt      := nil;
  7802.       _ptrsizesrt  := 0;
  7803.       _datasrt     := nil;
  7804.       _datasizesrt := 0
  7805.     end
  7806.   end;  
  7807.  
  7808.  
  7809.  
  7810.  
  7811.  
  7812.  
  7813.  
  7814.  
  7815.   {$F+}
  7816.   procedure eco_lib_init;
  7817.   begin
  7818.     conditionfuncptr_ := @std_condition;
  7819.     _envseg := memw[prefixseg:$2c];
  7820.     _envptr    := ptr(_envseg,0);
  7821.     envmemptr_ := nil;
  7822.     envsize_   := 0;
  7823.     _hidemouse := 0; __equipscn;
  7824.     _currows := 25; _curcolumns := 80;
  7825.     rows := _currows; cols := _curcolumns;
  7826.     _curmode := get_video_mode;
  7827.     if _curmode = 7 then baseofscreen := $b000 else baseofscreen := $b800;
  7828.     _curdevice := __retdvscn(
  7829.       _curmode,_curcolumns,_currows,
  7830.           _curactivepage,_curdisplaypage
  7831.     );
  7832.     vseg := baseofscreen; vofs := 0;
  7833.     {zero-out the clockarray.}
  7834.     fillchar(clockarray, sizeof(clockarray), nullchar);
  7835.     {start the program timer, aka clockarray(0).}
  7836.     with clockarray[0] do begin
  7837.       with clockstartdate do getdate({var} year,month,date,dayofweek);
  7838.       with clockstarttime do gettime({var} hour,minute,second,hundredth);
  7839.       clockisrunning := true
  7840.     end;
  7841.  
  7842.     _curdisplaypage := 0; _curactivepage := 0;
  7843.     if not __isconfil(__handlfil(output)) then __stdio;
  7844.     new(scn1); __savscn(scn1);
  7845.     _dospath := getenv('PATH'); __progname;
  7846.   end;
  7847.   {$F-}
  7848.  
  7849.  
  7850.  
  7851.  
  7852.  
  7853.  
  7854.  
  7855. {$IFNDEF USETURBODOS}
  7856.   {$L ECO_LIBD}
  7857.   {$L INTR}
  7858. {$ENDIF}
  7859.  
  7860.  
  7861.   {$L ECO_LIBS}
  7862.  
  7863.   {$L FETCHMEM}
  7864.   {$L RDSECTOR}
  7865.  
  7866.  
  7867.  
  7868. begin
  7869.   eco_lib_init;
  7870. end.
  7871.