home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 341.img / TCS161S.ZIP / SUBS3.PAS < prev    next >
Pascal/Delphi Source File  |  1989-11-28  |  22KB  |  800 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit subs3;
  5.  
  6. interface
  7.  
  8. uses crt,dos,mycomman,
  9.      gentypes,configrt,statret,gensubs,subs1,windows,subs2,modem,
  10.      protocol;
  11.  
  12. const local_file_header_signature = $04034b50;
  13.       central_file_header_signature = $02014b50;
  14.       end_central_dir_signature = $06054b50;
  15.       compression_methods: array[0..6] of string[8]=
  16.       (' Stored ',' Shrunk ','Reduce-1','Reduce-2','Reduce-3','Reduce-4','?');
  17.       uinbufsize=512;
  18.       hsize=8192;
  19.  
  20. type
  21.    signature_type = longint;
  22.  
  23.    local_file_header = record
  24.       version_needed_to_extract:    word;
  25.       general_purpose_bit_flag:     word;
  26.       compression_method:           word;
  27.       last_mod_file_time:           word;
  28.       last_mod_file_date:           word;
  29.       crc32:                        longint;
  30.       compressed_size:              longint;
  31.       uncompressed_size:            longint;
  32.       filename_length:              word;
  33.       extra_field_length:           word;
  34.    end;
  35.  
  36.    central_directory_file_header = record
  37.       version_made_by:                 word;
  38.       version_needed_to_extract:       word;
  39.       general_purpose_bit_flag:        word;
  40.       compression_method:              word;
  41.       last_mod_file_time:              word;
  42.       last_mod_file_date:              word;
  43.       crc32:                           longint;
  44.       compressed_size:                 longint;
  45.       uncompressed_size:               longint;
  46.       filename_length:                 word;
  47.       extra_field_length:              word;
  48.       file_comment_length:             word;
  49.       disk_number_start:               word;
  50.       internal_file_attributes:        word;
  51.       external_file_attributes:        longint;
  52.       relative_offset_local_header:    longint;
  53.    end;
  54.  
  55.    end_central_dir_record = record
  56.       number_this_disk:                         word;
  57.       number_disk_with_start_central_directory: word;
  58.       total_entries_central_dir_on_this_disk:   word;
  59.       total_entries_central_dir:                word;
  60.       size_central_directory:                   longint;
  61.       offset_start_central_directory:           longint;
  62.       zipfile_comment_length:                   word;
  63.    end;
  64.  
  65.    central_list_ptr = ^central_list;
  66.    central_list = record
  67.       dir:     central_directory_file_header;
  68.       name:    string;
  69.       extra:   string;
  70.       comment: string;
  71.       next:    central_list_ptr;
  72.    end;
  73.  
  74.    string8=string[8];
  75.  
  76.    sarray = array[0..255] of string[64];
  77.  
  78.    hsize_array_integer = array[0..hsize] of integer;
  79.    hsize_array_byte    = array[0..hsize] of byte;
  80.  
  81. var
  82.    zipfd:   dos_handle;
  83.    zipfn:   dos_filename;
  84.    efn:     dos_filename;
  85.    dir:     anystr;
  86.    var
  87.    zipname:       dos_filename;
  88.    scratchzip:    dos_filename;
  89.    pattern:       dos_filename;
  90.    extcount:      integer;
  91.    xrec:          central_directory_file_header;
  92.    rec:           local_file_header;
  93.    ofd:           dos_handle;
  94.    sig:           signature_type;
  95.    cdir:          central_list_ptr;
  96.    lcdir:         central_list_ptr;
  97.    endrec:        end_central_dir_record;
  98.    filename:      string;
  99.    extra:         string;
  100.    dups:          boolean;
  101.    zipeof:      boolean;
  102.    csize:       longint;
  103.    cusize:      longint;
  104.    cmethod:     integer;
  105.    ctime:       word;
  106.    cdate:       word;
  107.    inbuf:       array[1..uinbufsize] of byte;
  108.    inpos:       integer;
  109.    incnt:       integer;
  110.    pc:          byte;
  111.    pcbits:      byte;
  112.    pcbitv:      byte;
  113.    outbuf:      array[0..4096] of byte; {for rle look-back}
  114.    outpos:      longint;                {absolute position in outfile}
  115.    outcnt:      integer;
  116.    outfd:       dos_handle;
  117.    factor:      integer;
  118.    followers:   sarray;
  119.    exstate:     integer;
  120.    c:           integer;
  121.    v:           integer;
  122.    len:         integer;
  123.    prefix_of:   hsize_array_integer;
  124.    suffix_of:   hsize_array_byte;
  125.    stack:       hsize_array_byte;
  126.    stackp:      integer;
  127.  
  128. function getextdesc:string;
  129. function wildcardmatch (w,f:sstr):boolean;
  130. procedure get_string (len:word; var s:string);
  131. procedure itoa2 (i:integer; var sp);
  132. function format_date (date:word):string8;
  133. function format_time (time:word):string8;
  134. procedure process_local_file_header;
  135. procedure process_central_file_header;
  136. procedure process_end_central_dir;
  137. procedure process_headers;
  138. procedure listzip (name:dos_filename);
  139. procedure arcview (fname:lstr);
  140. procedure pakview (filename:lstr);
  141. procedure lharcview (filename:lstr);
  142. procedure zipview (fn:lstr);
  143. procedure extractzip (ffile,mainzip,todir:anystr);
  144. procedure extractarc (ffile,mainzip,todir:anystr);
  145. procedure extractpak (ffile,mainzip,todir:anystr);
  146. procedure extractlzh (ffile,mainzip,todir:anystr);
  147. procedure extract (ffile,mainzip,todir:anystr);
  148. procedure addtozip (zipname,fn:anystr);
  149. function getpath (dir:anystr):lstr;
  150. procedure getpathname (fname:lstr; var path:lstr; var name:sstr);
  151. procedure writefreespace (path:lstr);
  152. function allowxfer:boolean;
  153. procedure fileinfo (yiyiyi:integer);
  154.  
  155. implementation
  156.  
  157. function getextdesc:string;
  158.   var nappa:string[255];
  159.       a,b,c:string;
  160.       extdone:boolean;
  161.       finalcut:integer;
  162.   begin
  163.    getextdesc:='';
  164.    nappa:='';
  165.    extdone:=false;
  166.    finalcut:=0;
  167.    writeln (^P'Extended Description 3 Lines Max - Hit [CR] to end (Wordwrap Active)'^R);
  168.    writeln (^P'[--------|---------|---------|---------|---------|---------|---------|--------]'^R);
  169.    repeat
  170.     buflen:=80;
  171.     wordwrap:=true;
  172.     getstr (1);
  173.     finalcut:=finalcut+1;
  174.     if finalcut>2 then extdone:=true;
  175.     if length(input)<1 then extdone:=true else
  176.     nappa:=nappa+input;
  177.    until extdone;
  178.    wordwrap:=false;
  179.    getextdesc:=nappa;
  180.   end;
  181.  
  182.  
  183. (* ---------------------------------------------------------- *)
  184.  
  185. function wildcardmatch (w,f:sstr):boolean;
  186. var a,b:sstr;
  187.  
  188.     procedure transform (t:sstr; var q:sstr);
  189.     var p:integer;
  190.  
  191.       procedure filluntil (k:char; n:integer);
  192.       begin
  193.         while length(q)<n do q:=q+k
  194.       end;
  195.  
  196.       procedure dopart (mx:integer);
  197.       var k:char;
  198.       begin
  199.         repeat
  200.           if p>length(t)
  201.             then k:='.'
  202.             else k:=t[p];
  203.           p:=p+1;
  204.           case k of
  205.             '.':begin
  206.                   filluntil (' ',mx);
  207.                   exit
  208.                 end;
  209.             '*':filluntil ('?',mx);
  210.             else if length(q)<mx then q:=q+k
  211.           end
  212.         until 0=1
  213.       end;
  214.  
  215.     begin
  216.       p:=1;
  217.       q:='';
  218.       dopart (8);
  219.       dopart (11)
  220.     end;
  221.  
  222.     function theymatch:boolean;
  223.     var cnt:integer;
  224.     begin
  225.       theymatch:=false;
  226.       for cnt:=1 to 11 do
  227.         if (a[cnt]<>'?') and (b[cnt]<>'?') and
  228.            (upcase(a[cnt])<>upcase(b[cnt])) then exit;
  229.       theymatch:=true
  230.     end;
  231.  
  232.   begin
  233.     transform (w,a);
  234.     transform (f,b);
  235.     wildcardmatch:=theymatch
  236.   end;
  237.  
  238. (* ---------------------------------------------------------- *)
  239.  
  240. (* ---------------------------------------------------------- *)
  241. procedure get_string(len: word; var s: string);
  242. var
  243.    n: word;
  244. begin
  245.    if len > 255 then
  246.       len := 255;
  247.    n := dos_read(zipfd,s[1],len);
  248.    s[0] := chr(len);
  249. end;
  250.  
  251. (* ---------------------------------------------------------- *)
  252. procedure itoa2(i: integer; var sp);
  253. var
  254.    s: array[1..2] of char absolute sp;
  255. begin
  256.    s[1] := chr( (i div 10) + ord('0'));
  257.    s[2] := chr( (i mod 10) + ord('0'));
  258. end;
  259.  
  260. function format_date(date: word): string8;
  261. const
  262.    s:       string8 = 'mm-dd-yy';
  263. begin
  264.    itoa2(((date shr 9) and 127)+80, s[7]);
  265.    itoa2( (date shr 5) and 15,  s[1]);
  266.    itoa2( (date      ) and 31,  s[4]);
  267.    format_date := s;
  268. end;
  269.  
  270. function format_time(time: word): string8;
  271. const
  272.    s:       string8 = 'hh:mm:ss';
  273. begin
  274.    itoa2( (time shr 11) and 31, s[1]);
  275.    itoa2( (time shr  5) and 63, s[4]);
  276.    itoa2( (time shl  1) and 63, s[7]);
  277.    format_time := s;
  278. end;
  279.  
  280. (* ---------------------------------------------------------- *)
  281. procedure process_local_file_header;
  282. var
  283.    n:             word;
  284.    rec:           local_file_header;
  285.    filename:      string;
  286.    extra:         string;
  287.  
  288. begin
  289.    n := dos_read(zipfd,rec,sizeof(rec));
  290.    get_string(rec.filename_length,filename);
  291.    get_string(rec.extra_field_length,extra);
  292.    dos_lseek(zipfd,rec.compressed_size,seek_cur);
  293. end;
  294.  
  295. (* ---------------------------------------------------------- *)
  296. procedure process_central_file_header;
  297. var
  298.    n:             word;
  299.    rec:           central_directory_file_header;
  300.    filename:      string;
  301.    extra:         string;
  302.    comment:       string;
  303.  
  304. begin
  305.    n := dos_read(zipfd,rec,sizeof(rec));
  306.    get_string(rec.filename_length,filename);
  307.    get_string(rec.extra_field_length,extra);
  308.    get_string(rec.file_comment_length,comment);
  309.  
  310.    write(rec.uncompressed_size:7,'  ',
  311.            compression_methods[rec.compression_method]:8,' ',
  312.            rec.compressed_size:7,'   ',
  313.            format_date(rec.last_mod_file_date),'  ',
  314.            format_time(rec.last_mod_file_time));
  315.  
  316.    if (rec.internal_file_attributes and 1) <> 0 then
  317.       write('   Ascii  ')
  318.    else
  319.       write('  Binary  ');
  320.  
  321.    writeln(filename);
  322.  
  323. (**************
  324.    writeln;
  325.    writeln('central file header');
  326.    writeln('   filename = ',filename);
  327.    writeln('   extra = ',extra);
  328.    writeln('   file comment = ',comment);
  329.    writeln('   version_made_by = ',rec.version_made_by);
  330.    writeln('   version_needed_to_extract = ',rec.version_needed_to_extract);
  331.    writeln('   general_purpose_bit_flag = ',rec.general_purpose_bit_flag);
  332.    writeln('   compression_method = ',rec.compression_method);
  333.    writeln('   last_mod_file_time = ',rec.last_mod_file_time);
  334.    writeln('   last_mod_file_date = ',rec.last_mod_file_date);
  335.    writeln('   crc32 = ',rec.crc32);
  336.    writeln('   compressed_size = ',rec.compressed_size);
  337.    writeln('   uncompressed_size = ',rec.uncompressed_size);
  338.    writeln('   disk_number_start = ',rec.disk_number_start);
  339.    writeln('   internal_file_attributes = ',rec.internal_file_attributes);
  340.    writeln('   external_file_attributes = ',rec.external_file_attributes);
  341.    writeln('   relative_offset_local_header = ',rec.relative_offset_local_header);
  342. ***********)
  343.  
  344. end;
  345.  
  346.  
  347. (* ---------------------------------------------------------- *)
  348. procedure process_end_central_dir;
  349. var
  350.    n:             word;
  351.    rec:           end_central_dir_record;
  352.    comment:       string;
  353.  
  354. begin
  355.    n := dos_read(zipfd,rec,sizeof(rec));
  356.    get_string(rec.zipfile_comment_length,comment);
  357.  
  358. (*******
  359.    writeln;
  360.    writeln('end central dir');
  361.    writeln('   zipfile comment = ',comment);
  362.    writeln('   number_this_disk = ',rec.number_this_disk);
  363.    writeln('   number_disk_with_start_central_directory = ',rec.number_disk_with_start_central_directory);
  364.    writeln('   total_entries_central_dir_on_this_disk = ',rec.total_entries_central_dir_on_this_disk);
  365.    writeln('   total_entries_central_dir = ',rec.total_entries_central_dir);
  366.    writeln('   size_central_directory = ',rec.size_central_directory);
  367.    writeln('   offset_start_central_directory = ',rec.offset_start_central_directory);
  368. ********)
  369.  
  370. end;
  371.  
  372. (* ---------------------------------------------------------- *)
  373. procedure process_headers;
  374. var
  375.    sig:  longint;
  376.    fail: integer;
  377.  
  378. begin
  379.    fail := 0;
  380.  
  381.    while true do
  382.    begin
  383.  
  384.       if dos_read(zipfd,sig,sizeof(sig)) <> sizeof(sig) then
  385.          exit
  386.       else
  387.  
  388.       if sig = local_file_header_signature then
  389.          process_local_file_header
  390.       else
  391.  
  392.       if sig = central_file_header_signature then
  393.          process_central_file_header
  394.       else
  395.  
  396.       if sig = end_central_dir_signature then
  397.       begin
  398.          process_end_central_dir;
  399.          exit;
  400.       end
  401.       else
  402.  
  403.       begin
  404.          inc(fail);
  405.          if fail > 100 then
  406.          begin
  407.             writeln('Invalid Zipfile Header!');
  408.             exit;
  409.          end;
  410.       end;
  411.    end;
  412. end;
  413.  
  414. (* ---------------------------------------------------------- *)
  415. procedure listzip(name: dos_filename);
  416. begin
  417.    zipfd := dos_open(name,open_read);
  418.    if zipfd = dos_error then
  419.    begin
  420.       writeln('Can''t open: ',name);
  421.       exit;
  422.    end;
  423.    writeln;
  424.    if (pos('?',zipfn)+pos('*',zipfn)) > 0 then
  425.    begin
  426.       writeln('Zipfile: '+name);
  427.       writeln;
  428.    end;
  429.    writeln('  Size    Method   Zipped     Date      Time     Type     File Name');
  430.    if (asciigraphics in urec.config) then
  431.    writeln('──────── ──────── ────────  ────────  ────────  ──────  ─────────────')
  432.    else
  433.    writeln('-------- -------- --------  --------  --------  ------  -------------');
  434.    process_headers;
  435.    dos_close(zipfd);
  436. end;
  437.  
  438. (* ---------------------------------------------------------- *)
  439.  
  440. procedure arcview (fname:lstr);
  441. var f:file of byte;
  442.     b:byte;
  443.     sg:boolean;
  444.     size:longint;
  445.     n:integer;
  446.  
  447. function getsize:longint;
  448. var x:longint;
  449.     b:array [1..4] of byte absolute x;
  450.     cnt:integer;
  451. begin
  452.  for cnt:=1 to 4 do read (f,b[cnt]);
  453.  getsize:=x
  454. end;
  455.  
  456. begin
  457.  assign (f,fname);
  458.  reset (f);
  459.  iocode:=ioresult;
  460.  if iocode<>0 then begin
  461.   fileerror ('LISTARCHIVE',fname);
  462.   exit;
  463.  end;
  464.  if (filesize(f)<32) then begin
  465.   writeln (^M'That file isn''t an archive!');
  466.   close (f);
  467.   exit;
  468.  end;
  469.  writeln ('Filename.Ext    Size');
  470.  if (asciigraphics in urec.config) then
  471.  writeln ('────────────    ────') else
  472.  writeln ('------------    ----');
  473.  repeat
  474.   read (f,b);
  475.   if b<>26 then begin
  476.    writeln (^M'That file isn''t an archive!');
  477.    close (f);
  478.    exit
  479.   end;
  480.   read (f,b);
  481.   if b=0 then begin
  482.    close (f);
  483.    exit
  484.   end;
  485.   sg:=false;
  486.   for n:=1 to 13 do begin
  487.    read (f,b);
  488.    if b=0 then sg:=true;
  489.    if sg then b:=32;
  490.    write (chr(b))
  491.   end;
  492.   size:=getsize;
  493.   for n:=1 to 6 do read (f,b);
  494.   writeln ('   ',getsize);
  495.   seek (f,filepos(f)+size)
  496.  until break or hungupon;
  497. end;
  498.  
  499. procedure pakview (filename:lstr);
  500. var f:file of byte;
  501. begin
  502.  if not exist (pak) then begin
  503.   writeln (^M'Error: '+pak+' not found. Notify Sysop.'^M);
  504.   exit;
  505.  end;
  506.  exec (GetEnv('COMSPEC'),'/C '+pak+' v '+filename+' >PAK.LST');
  507.  printfile ('PAK.LST')
  508. end;
  509.  
  510. procedure lharcview (filename:lstr);
  511. var f:file of byte;
  512. begin
  513.  if not exist (lharc) then begin
  514.   writeln (^M'Error: '+lharc+' not found. Notify Sysop.'^M);
  515.   exit;
  516.  end;
  517.  exec (GetEnv('COMSPEC'),'/C '+lharc+' v '+filename+' >LHARC.LST');
  518.  printfile ('LHARC.LST')
  519. end;
  520.  
  521. procedure zipview (fn:lstr);
  522. var f:file of byte;
  523.     dirinfo:searchrec;
  524.     dir,nam,ext:dos_filename;
  525. begin
  526.  assign (f,fn);
  527.  reset (f);
  528.  iocode:=ioresult;
  529.  if iocode<>0 then begin
  530.   fileerror ('LISTARCHIVE',fn);
  531.   exit;
  532.  end;
  533.  if (filesize(f)<32) then begin
  534.   writeln (^M'That file isn''t an archive!');
  535.   close (f);
  536.   exit;
  537.  end;
  538.  close (f);
  539.  zipfn:=fn;
  540.  if pos('.',zipfn)=0 then zipfn:=zipfn+'.ZIP';
  541.  fsplit(zipfn,dir,nam,ext);
  542.  findfirst(zipfn,$21,dirinfo);
  543.  while (doserror=0) do
  544.  begin
  545.   listzip (dir+dirinfo.name);
  546.   findnext (dirinfo);
  547.  end;
  548. end;
  549.  
  550. procedure extractzip (ffile,mainzip,todir:anystr);
  551. var f:file of byte;
  552. begin
  553.  if forumdir[length(forumdir)]<>'\' then forumdir:=forumdir+'\';
  554.  if not exist (forumdir+'PKUNZIP.EXE') then begin
  555.   writeln (^M'Error: PKUNZIP.EXE not found [supposed to be in '+forumdir+'].');
  556.   writeln ('Please notify Sysop!!');
  557.   exit;
  558.  end;
  559.  exec (GetEnv('COMSPEC'),'/C '+forumdir+'PKUNZIP.EXE '+mainzip+' '+ffile+' '+todir+' >NUL');
  560. end;
  561.  
  562. procedure extractarc (ffile,mainzip,todir:anystr);
  563. var f1,f2,f3:anystr;
  564. begin
  565.  if forumdir[length(forumdir)]<>'\' then forumdir:=forumdir+'\';
  566.  f1:=forumdir+'PKUNPAK.EXE';
  567.  f2:=forumdir+'PKXARC.EXE';
  568.  f3:=forumdir+'PKXARC.COM';
  569.  if ((not exist (f1)) and (not exist (f2)) and (not exist (f3))) then
  570.  begin
  571.   writeln (^M'Error: PKUNPAK.EXE, PKXARC.EXE, or PKXARC.COM not found!');
  572.   writeln ('There are supposed to be in '+forumdir+'.');
  573.   writeln ('Please notify Sysop!!');
  574.   exit;
  575.  end;
  576.  if exist (f1) then exec (GetEnv('COMSPEC'),'/C '+f1+' '+mainzip+' '+ffile+' '+todir) else
  577.  if exist (f2) then exec (GetEnv('COMSPEC'),'/C '+f2+' '+mainzip+' '+ffile+' '+todir) else
  578.  if exist (f3) then exec (GetEnv('COMSPEC'),'/C '+f3+' '+mainzip+' '+ffile+' '+todir);
  579. end;
  580.  
  581. procedure extractpak (ffile,mainzip,todir:anystr);
  582. begin
  583.  if forumdir[length(forumdir)]<>'\' then forumdir:=forumdir+'\';
  584.  if not exist (pak) then begin
  585.   writeln (^M'Error: '+pak+' not found!');
  586.   writeln ('Please notify Sysop!!');
  587.   exit;
  588.  end;
  589.  exec (GetEnv('COMSPEC'),'/C '+pak+' '+mainzip+' '+ffile+' '+todir);
  590. end;
  591.  
  592. procedure extractlzh (ffile,mainzip,todir:anystr);
  593. begin
  594.  if forumdir[length(forumdir)]<>'\' then forumdir:=forumdir+'\';
  595.  if not exist (lharc) then begin
  596.   writeln (^M'Error: '+lharc+' not found!');
  597.   writeln ('Please notify Sysop!!');
  598.   exit;
  599.  end;
  600.  exec (GetEnv('COMSPEC'),'/C '+lharc+' '+mainzip+' '+ffile+' '+todir);
  601. end;
  602.  
  603. procedure extract (ffile,mainzip,todir:anystr);
  604. var t:sstr;
  605.     x:integer;
  606. begin
  607.  x:=pos ('.',mainzip);
  608.  t:=copy (mainzip,x+1,3);
  609.  t:=upstring(t);
  610.  if t='ZIP' then extractzip (ffile,mainzip,todir) else
  611.  if t='ARC' then extractarc (ffile,mainzip,todir) else
  612.  if t='PAK' then extractpak (ffile,mainzip,todir) else
  613.  if t='LZH' then extractlzh (ffile,mainzip,todir);
  614. end;
  615.  
  616. procedure addtozip (zipname,fn:anystr);
  617. begin
  618.  if forumdir[length(forumdir)]<>'\' then forumdir:=forumdir+'\';
  619.  if not exist (forumdir+'PKZIP.EXE') then begin
  620.   writeln (^M'Error: PKZIP.EXE not found [supposed to be in '+forumdir+'].');
  621.   writeln ('Please notify Sysop!!');
  622.   exit;
  623.  end;
  624.  exec (GetEnv('COMSPEC'),'/C '+forumdir+'PKZIP.EXE -ex '+zipname+' '+fn+' >NUL');
  625. end;
  626.  
  627. function getpath (dir:anystr):lstr;
  628.   var q,r:integer;
  629.       f:file;
  630.       b,found:boolean;
  631.       p,s:lstr;
  632.       t:text;
  633.   begin
  634.     getpath:=dir;
  635.     if ulvl<sysoplevel then exit;
  636.     repeat
  637.       found:=false;
  638.       writestr ('Upload Path [CR/'+dir+']:');
  639.       if hungupon then exit;
  640.       if length(input)=0 then input:=dir;
  641.       p:=input;
  642.       if input[length(p)]<>'\' then p:=p+'\';
  643.       b:=true;
  644.       if exist (forumdir+'SECURITY.DIR') then begin
  645.        assign (t,forumdir+'SECURITY.DIR');
  646.        reset (t);
  647.        repeat
  648.         readln (t,s);
  649.         if s[length(s)]<>'\' then s:=s+'\';
  650.         if match(s,p) then begin
  651.          found:=true;
  652.          writeln;
  653.          writeln (^G'That Directory is protected by the Sysop!');
  654.          writeln;
  655.         end;
  656.        until eof(t) or (found);
  657.        textclose (t);
  658.        if found then exit;
  659.       end;
  660.       assign (f,p+'CON');
  661.       reset (f);
  662.       q:=ioresult;
  663.       close (f);
  664.       r:=ioresult;
  665.       if q<>0 then begin
  666.         writestr ('  Path doesn''t exist!  Create it [y/n]? *');
  667.         b:=yes;
  668.         if b then begin
  669.           mkdir (copy(p,1,length(p)-1));
  670.           q:=ioresult;
  671.           b:=q=0;
  672.           if b
  673.             then writestr ('Directory created')
  674.             else writestr ('Unable to create directory')
  675.         end
  676.       end
  677.     until b;
  678.     getpath:=p
  679.   end;
  680.  
  681.   procedure getpathname (fname:lstr; var path:lstr; var name:sstr);
  682.   var p:integer;
  683.   begin
  684.     path:='';
  685.     repeat
  686.       p:=pos('\',fname);
  687.       if p<>0 then begin
  688.         path:=path+copy(fname,1,p);
  689.         fname:=copy(fname,p+1,255)
  690.       end
  691.     until p=0;
  692.     name:=fname
  693.   end;
  694.  
  695.   procedure writefreespace (path:lstr);
  696.  
  697.   function unsigned (i:integer):real;
  698.   begin
  699.     if i>=0
  700.       then unsigned:=i
  701.       else unsigned:=65536.0+i
  702.   end;
  703.  
  704.   var drive:byte;
  705.       r:registers;
  706.       csize,free,total:real;
  707.   begin
  708.     r.ah:=$36;
  709.     r.dl:=ord(upcase(path[1]))-64;
  710.     intr ($21,r);
  711.     if r.ax=-1 then begin
  712.       writeln ('Invalid Drive!');
  713.       exit
  714.     end;
  715.     csize:=unsigned(r.ax)*unsigned(r.cx);
  716.     free:=csize*unsigned(r.bx);
  717.     total:=csize*unsigned(r.dx);
  718.     free:=free/1024;
  719.     total:=total/1024;
  720.     write (free:0:0,'k ');
  721.     if free<125 then write ('(minimal!) ');
  722.     writeln ('out of ',total:0:0,'k')
  723.   end;
  724.  
  725.   function allowxfer:boolean;
  726.   var cnt:baudratetype;
  727.       k:char;
  728.   begin
  729.     allowxfer:=false;
  730.     for cnt:=firstbaud to lastbaud do
  731.       if baudrate=baudarray[cnt]
  732.         then if not (cnt in downloadrates)
  733.           then begin
  734.             writeln ('Sorry, File Transfer is not allowed at ',baudrate,' Baud!');
  735.             exit
  736.           end;
  737.     if parity then begin
  738.       writeln ('Please select NO Parity (N,8,1) and hit [Return]:');
  739.       parity:=false;
  740.       setparam (usecom,baudrate,parity);
  741.       repeat
  742.         k:=getchar;
  743.         if hungupon then exit
  744.       until k in [#13,#141];
  745.       if k=#141 then begin
  746.         parity:=true;
  747.         setparam (usecom,baudrate,parity);
  748.         writeln ('You did not turn off parity.  Transfer aborted.');
  749.         exit
  750.       end
  751.     end;
  752.     allowxfer:=true
  753.   end;
  754.  
  755.   procedure fileinfo (yiyiyi:integer);
  756.   var i:integer;
  757.       ud:udrec;
  758.       okay:boolean;
  759.       a,b,c:string;
  760.   begin
  761.    if nofiles then exit;
  762.    i:=yiyiyi;
  763.    if i<1 then begin
  764.     i:=getfilenum ('get Info on');
  765.     if i=0 then exit;
  766.    end;
  767.    seekudfile (i);
  768.    read (udfile,ud);
  769.    okay:=checkok (ud);
  770.    if not okay then exit;
  771.    writehdr ('Extended File Information');
  772.     writeln (^R'   Filename: '^S,ud.filename);
  773.     writeln (^R'       Size: '^S,ud.filesize);
  774.     writeln (^R'     Points: '^S,ud.points);
  775.     writeln (^R'Description: '^S,ud.descrip);
  776.     writeln (^R'  Times D/L: '^S,ud.downloaded);
  777.     writeln (^R'Unrated/New: '^S,yesno(ud.newfile));
  778.     writeln (^R'Special Ask: '^S,yesno(ud.specialfile));
  779.     writeln (^R'    Sent by: '^S,ud.sentby);
  780.     writeln (^R'    Sent on: '^S,datestr(ud.when));
  781.     writeln (^R'    Sent at: '^S,timestr(ud.when));
  782.     writeln ('Extended Desc: '^S);
  783.     a:=copy (ud.extdesc,1,80);
  784.     ansicolor (urec.statcolor);
  785.     writeln (a);
  786.     if length(ud.extdesc)>80 then begin
  787.      b:=copy (ud.extdesc,81,80);
  788.      ansicolor (urec.statcolor);
  789.      writeln (b);
  790.     end;
  791.     if length(ud.extdesc)>160 then begin
  792.      c:=copy (ud.extdesc,161,80);
  793.      ansicolor (urec.statcolor);
  794.      writeln (c);
  795.     end;
  796.   end;
  797.  
  798. begin
  799. end.
  800.