home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FORUM25C.ZIP / UDASCII.SUB < prev    next >
Encoding:
Text File  |  1989-01-29  |  3.6 KB  |  135 lines
  1. {=============================================================================}
  2.  
  3.   Procedure sendfile (fn:integer);
  4.   VAR f:filerec;
  5.       cnt:integer;
  6.       k:char;
  7.       q:file of byte;
  8.   label exit;
  9.   begin
  10.     seekffile (fn);
  11.     read (ffile,f);
  12.     assign (q,f.fname);
  13.     reset (q);
  14.     iocode:=ioresult;
  15.     if iocode<>0 then begin
  16.       fileerror (f.fname,'SENDFILE (Ascii download)');
  17.       goto exit
  18.     end;
  19.     writelog (4,1,f.descrip);
  20.     writeln ('File:        '^S,f.descrip);
  21.     writeln ('Uploaded by: '^S,f.sentby);
  22.     writeln ('Downloaded:  '^s,f.downloaded);
  23.     writeln ('File size:   '^S,filesize(q),' characters'^M);
  24.     writeln (^B'Press space when you''re ready, or [X] to abort...');
  25.     repeat
  26.       repeat until charready;
  27.       k:=readchar;
  28.       if hungupon then goto exit;
  29.       if upcase(k)='X' then goto exit
  30.     until k=' ';
  31.     if not hungupon
  32.       then
  33.         begin
  34.           printfile (f.fname);
  35.           f.downloaded:=f.downloaded+1;
  36.           seekffile (fn);
  37.           write (ffile,f);
  38.           writeln (^B^M+asciidownload+^M'Press a key...');
  39.           repeat until charready;
  40.           k:=readchar
  41.         end;
  42.     exit:
  43.     close (q)
  44.   end;
  45.  
  46. {=============================================================================}
  47.  
  48.   Procedure receivefile (f:filerec);
  49.   VAR fn:lstr;
  50.       cnt,timeul:integer;
  51.       k:char;
  52.       done:boolean;
  53.       fff:text;
  54.       last3:array [1..3] of char;
  55.  
  56.     Procedure putchar (k:char);
  57.     begin
  58.       write (fff,k);
  59.       write (usr,k)
  60.     end;
  61.  
  62.   begin
  63.     fn:='';
  64.     cnt:=1;
  65.     timeul:=timer;
  66.     repeat
  67.       if cnt<=length(f.descrip) then begin
  68.         k:=upcase(f.descrip[cnt]);
  69.         if k in ['A'..'Z'] then fn:=fn+k
  70.       end;
  71.       cnt:=cnt+1
  72.     until cnt>length(f.descrip);
  73.     if fn='' then fn:='Noname';
  74.     fn:=copy(fn,1,8);
  75.     while devicename(fn) do fn:=fn+chr(random(26)+64);
  76.     fn:=uploaddir+fn+'.';
  77.     cnt:=0;
  78.     repeat
  79.       cnt:=cnt+1
  80.     until (cnt=1000) or (not exist(fn+strr(cnt)));
  81.     if cnt=1000 then begin
  82.       writeln ('Please try another description!');
  83.       exit
  84.     end;
  85.     fn:=fn+strr(cnt);
  86.     assign (fff,fn);
  87.     rewrite (fff);
  88.     iocode:=ioresult;
  89.     if iocode<>0 then begin
  90.       error ('%I opening %1 in RECEIVEFILE (ASCII upload)','',fn);
  91.       exit
  92.     end;
  93.     f.fname:=fn;
  94.     f.sentby:=unam;
  95.     f.downloaded:=0;
  96.     f.when:=now;
  97.     writeln (^B'ASCII receive ready.'^M,
  98.              'Press [CR] and /E to end, /X to abort.'^M);
  99.     textcolor (outlockcolor);
  100.     repeat
  101.       repeat until charready;
  102.       if hungupon
  103.         then done:=true
  104.         else
  105.           begin
  106.             k := chr(ord(readchar));
  107.             last3[1]:=last3[2];
  108.             last3[2]:=last3[3];
  109.             last3[3]:=upcase(k);
  110.             done:=((last3[1]=^M) or (last3[1]=^J))
  111.                   and (last3[2]='/') and ((last3[3]='E') or (last3[3]='X'));
  112.             if not done then begin
  113.               if (last3[2]=^M) and (k<>^J) then putchar (^J);
  114.               if last3[2]='/' then putchar ('/');
  115.               if k<>'/'
  116.                 then putchar (k)
  117.             end
  118.           end
  119.     until done;
  120.     textclose (fff);
  121.     textcolor (normbotcolor);
  122.     if last3[3]='E' then begin
  123.       addfile (f);
  124.       timeul:=timer-timeul;
  125.       if timeul<0 then timeul:=timeul+1440;
  126.       writeln (^B^M'That upload took ',timeul,' minutes.');
  127.       logontime:=logontime+timeul;
  128.       writelog (4,2,f.descrip)
  129.     end else begin
  130.       writestr (^M^M'Upload aborted!');
  131.       erase (fff);
  132.       iocode:=ioresult
  133.     end
  134.   end;
  135.