home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 341.img / TCS161S.ZIP / FILE2.PAS < prev    next >
Pascal/Delphi Source File  |  1989-09-23  |  10KB  |  405 lines
  1. var ud:udrec;
  2.     curarea:integer;
  3.     offliney,vcr:boolean;
  4.     validprotos:set of char;
  5.     xtype:char;
  6.  
  7.   procedure beepbeep (ok:integer);
  8.   begin
  9.     delay (500);
  10.     write (^B^M);
  11.     case ok of
  12.       0:write ('Xfer completed!');
  13.       1:write ('Xfer Aborted just before EOF!');
  14.       2:write ('Xfer Aborted!')
  15.     end;
  16.     writeln (^G^M)
  17.   end;
  18.  
  19.   procedure seekafile (n:integer);
  20.   begin
  21.     seek (afile,n-1)
  22.   end;
  23.  
  24.   function numareas:integer;
  25.   begin
  26.     numareas:=filesize (afile)
  27.   end;
  28.  
  29.   procedure seekudfile (n:integer);
  30.   begin
  31.     seek (udfile,n-1)
  32.   end;
  33.  
  34.   function numuds:integer;
  35.   begin
  36.     numuds:=filesize (udfile)
  37.   end;
  38.  
  39.   procedure assignud;
  40.   begin
  41.     close (udfile);
  42.     assign (udfile,'AREA'+strr(curarea))
  43.   end;
  44.  
  45.   function sponsoron:boolean;
  46.   begin
  47.     sponsoron:=match(area.sponsor,unam) or issysop
  48.   end;
  49.  
  50.   function getapath:lstr;
  51.   begin
  52.    getapath:=area.xmodemdir;
  53.    getapath:=getpath (area.xmodemdir);
  54.   end;
  55.  
  56.   function makearea:boolean;
  57.   var num,n:integer;
  58.       a:arearec;
  59.   begin
  60.     makearea:=false;
  61.     num:=numareas+1;
  62.     n:=numareas;
  63.     writestr ('Create Area '+strr(num)+' [y/n]? *');
  64.     if yes then begin
  65.       writestr ('Area Name: &');
  66.       if length(input)=0 then exit;
  67.       a.name:=input;
  68.       writestr ('Access Level:');
  69.       if length(input)=0 then exit;
  70.       a.level:=valu(input);
  71.       {writestr ('Group Access (y/n):');
  72.       if yes then a.usegroup:=true else a.usegroup:=false;
  73.       if a.usegroup then begin
  74.         writestr ('Group Filename:');
  75.         a.groupfn:=input;
  76.       end;  }
  77.       writestr ('Sponsor [CR/'+unam+']:');
  78.       if length(input)=0 then input:=unam;
  79.       a.sponsor:=input;
  80.     { writestr ('Entry Password [CR/None]:');
  81.       if length(input)=0 then a.areapw:='' else
  82.       a.areapw:=input; }
  83.       writestr ('Able to Upload into this area? [CR/Yes]:');
  84.       if (length(input)=0) or (upcase(input[1])='Y') then
  85.       a.upload:=true else a.upload:=false;
  86.       writestr ('Able to Download from this area? [CR/Yes]:');
  87.       if (length(input)=0) or (upcase(input[1])='Y') then
  88.       a.download:=true else a.download:=false;
  89.       a.xmodemdir:=getapath;
  90.       seekafile (num);
  91.       write (afile,a);
  92.       area:=a;
  93.       curarea:=num;
  94.       assignud;
  95.       rewrite (udfile);
  96.       writeln ('Area created');
  97.       makearea:=true;
  98.       writelog (15,4,a.name)
  99.     end
  100.   end;
  101.  
  102.   procedure setarea (n:integer);
  103.   var t:text;
  104.       l:string;
  105.  
  106.     procedure nosucharea;
  107.     begin
  108.       writeln (^B'Invalid File Area!')
  109.     end;
  110.  
  111.   begin
  112.     curarea:=n;
  113.     if (n>numareas) or (n<1) then begin
  114.       nosucharea;
  115.       if issysop
  116.         then if makearea
  117.           then setarea (curarea)
  118.           else setarea (1)
  119.         else setarea (1);
  120.       exit
  121.     end;
  122.     seekafile (n);
  123.     read (afile,area);
  124.   { if area.usegroup then begin
  125.       assign (t,area.groupfn);
  126.       reset (t);
  127.       repeat
  128.         readln (t,l);
  129.         write ('Please Wait...');
  130.       until (eof(t)) or (match(l,unam));
  131.       write ('Uh Huh.');
  132.       if (match(unam,l)) then setarea (curarea)
  133.       else nosucharea;
  134.     end else  }
  135.     if (urec.udlevel<area.level) and (not issysop)
  136.       then if curarea=1
  137.         then error ('User can''t access first area','','')
  138.         else
  139.           begin
  140.             nosucharea;
  141.             setarea (1);
  142.             exit
  143.           end;
  144.    { if length(area.areapw)>0 then begin
  145.      writeln;
  146.      writestr ('Entry Password:');
  147.      if length(input)=0 then exit;
  148.      if not match(input,area.areapw) then exit;
  149.     end; }
  150.     assignud;
  151.     close (t);
  152.     close (udfile);
  153.     reset (udfile);
  154.     if ioresult<>0 then rewrite (udfile);
  155.     writeln (^B^M'Area: '^S,area.name,^R' ['^S,curarea,^R']');
  156.     if sponsoron then writeln (^R'['^S'%'^R']:Xfer Sponsor Commands');
  157.     writeln
  158.   end;
  159.  
  160.  
  161.   procedure spacelen(le:byte);
  162.    var aaa:byte;
  163.    begin
  164.     for aaa:=1 to le do
  165.     write(' ');
  166.    end;
  167.   procedure linelen(le:byte);
  168.    var aaa:byte;
  169.    begin
  170.     for aaa:=1 to le do
  171.     write('─');
  172.    end;
  173.  
  174.  Procedure toplinearea;
  175.    begin
  176.    writeln (^R'┌───┬───────────────────────────────────────┬───────┬─────┬──────┐');
  177.    writeln (^R'│ '^U'#'^R' │ '^U'Area Name'^R'                             │ '^U'Level'^R' │ '^U'UPL'^R' │ '^U'DOWN'^R' │');
  178.    writeln (^R'├───┼───────────────────────────────────────┼───────┼─────┼──────┤');
  179.    end;
  180.  Procedure bottomlinearea;
  181.  begin
  182.  writeln (^R'└───┴───────────────────────────────────────┴───────┴─────┴──────┘');
  183.  end;
  184.  Procedure topfileline;
  185.  begin;
  186.    writeln (^R'┌───┬──────────────┬────────┬───────────┬─────────────────────────────────────┐');
  187.    writeln (^R'│ '^U'# '^R'│ '^U'Filename     '^R'│'^U' Points '^R'│'^U' Size      '^R'│'^U' Description'^R+
  188.           '                         │');
  189.    writeln (^R'├───┼──────────────┼────────┼───────────┼─────────────────────────────────────┤');
  190.  end;
  191.  Procedure bottomfileline;
  192.  begin
  193.    writeln (^R'└───┴──────────────┴────────┴───────────┴─────────────────────────────────────┘');
  194.  end;
  195.  procedure listareas;
  196.  
  197.   var a:arearec;
  198.       cnt:integer;
  199.   begin
  200.    if exist (textfiledir+'Filearea.BBS') then
  201.    printfile (textfiledir+'Filearea.BBS') else
  202.    begin
  203.     writehdr ('File Area List');
  204.     seekafile (1);
  205.     toplinearea;
  206.     for cnt:=1 to numareas do begin
  207.       read (afile,a);
  208.       if a.level<=urec.udlevel
  209.         then begin
  210.         write (^R'│'^U,cnt);
  211.         spacelen(3-length(strr(cnt)));
  212.         write (^R'│ '^U,a.name,^R);
  213.         spacelen(38-length(a.name));
  214.         write (^R'│'^U,a.level,^R);
  215.         spacelen(7-length(strr(a.level)));
  216.     if a.upload then
  217.         write(^R'│ '^U'YES ')
  218.      else
  219.         write(^R'│ '^U'NO  ');
  220.      if a.download then
  221.         writeLn(^R'│ '^U'YES'^R'  │')
  222.      else
  223.         writeLn(^R'│ '^U'NO'^R'   │');
  224.  
  225.  
  226.        end;
  227.       if break then exit
  228.     end;
  229.    end;
  230.  bottomlinearea;
  231.  
  232.   end;
  233.  
  234.   function getareanum:integer;
  235.   var areastr:sstr;
  236.       areanum:integer;
  237.   begin
  238.     getareanum:=0;
  239.     if length(input)>1
  240.       then areastr:=copy(input,2,255)
  241.       else begin
  242.         listareas;
  243.         repeat
  244.           writestr (^M'Area Number [?/List]:');
  245.           if input='?' then listareas else areastr:=input
  246.         until (input<>'?') or hungupon;
  247.       end;
  248.     if length(areastr)=0 then exit;
  249.     areanum:=valu(areastr);
  250.     if (areanum>0) and (areanum<=numareas)
  251.       then getareanum:=areanum
  252.       else begin
  253.         writestr ('No such area!');
  254.         if issysop then if makearea then getareanum:=numareas
  255.       end
  256.   end;
  257.  
  258.   procedure getarea;
  259.   var areanum:integer;
  260.   begin
  261.     areanum:=getareanum;
  262.     if areanum<>0 then setarea (areanum)
  263.   end;
  264.  
  265.   function getfname (path:lstr; name:mstr):lstr;
  266.   var l:lstr;
  267.   begin
  268.     l:=path;
  269.     if length(l)<>0
  270.       then if not (l[length(l)] in [':','\'])
  271.         then l:=l+'\';
  272.     l:=l+name;
  273.     getfname:=l
  274.   end;
  275.  
  276.  
  277.   procedure listfile (n:integer; extended:boolean);
  278.  
  279.   var ud       :udrec;
  280.       q        :sstr;
  281.       a        :string;
  282.       b        :string;
  283.       c        :string;
  284.       ed       :string;
  285.       desc     :string;
  286.       lamedata :string[1];
  287.       up1      :byte;
  288.       dah      :boolean;
  289.   begin
  290.     seekudfile (n);
  291.     read (udfile,ud);
  292.     write (^R'│'^S+strr(n)+^R);
  293.     spacelen(3-length(strr(n)));
  294.     write (^R'│');
  295.     write(^S+' ',UPSTRING(ud.filename));
  296.     spacelen(13-length(ud.filename));
  297.     write (^R'│'^S);
  298.     desc:=ud.descrip;
  299.     dah:=false;
  300.     if ud.newfile
  301.       then write (^U'['^S'New'^U']   ')
  302.       else if ud.specialfile
  303.         then write (^U'['^S'Ask'^U']   ')
  304.         else if ud.points>0
  305.           then tab (strr(ud.points),8)
  306.           else write (^U'['^S'Free'^U']  ');
  307.     write (^R'│');
  308. if exist (getfname(ud.path,ud.filename)) then begin
  309. write(^S,strlong(ud.filesize));
  310. spacelen(11-length(strlong(ud.filesize)));
  311. write (^R'│');
  312. end;
  313. if not exist (getfname(ud.path,ud.filename)) then begin
  314.      write (^U'['^S'Offline'^U']'^R'  │');
  315. end;
  316.    if length(ud.descrip)<=2 then begin
  317.     write (^U'['^S' No Description '^U']');
  318.     spacelen(19);
  319.     writeLn(^R'│');
  320.     end;
  321.    if length(ud.descrip)>38 then begin
  322.  repeat
  323.    up1:=37;
  324.  repeat
  325.    dec(up1);
  326.    lamedata:=copy(desc,up1,1);
  327.  
  328.  if (lamedata=' ') and (dah=true) and (length(desc)>38) then begin
  329.   inc(cn);
  330.   write (^R'│   │              │        │           │');
  331.   write(^S+copy(desc,1,up1));
  332.   spacelen(37-length(copy(desc,1,up1)));
  333.   writeln(^R'│');
  334.   delete(desc,1,up1);
  335.  end;
  336.  
  337.  if (lamedata=' ') and (dah=false) then begin
  338.    inc(cn);
  339.    write(^s,copy(desc,1,up1));
  340.    spacelen(37-length(copy(desc,1,up1)));
  341.    writeln(^R,'│');
  342.    delete(desc,1,up1);
  343.    dah:=true
  344.  end;
  345.  
  346.  until (lamedata=' ')
  347.  until (length(desc)<=37);
  348.  end;
  349. if length(ud.descrip)>38 then begin
  350.  write (^R'│   │              │        │           │');
  351. end;
  352. if length(desc)>2 then begin
  353.  write(^S+desc);
  354.  spacelen(37-length(desc));
  355.  writeln(^R'│');
  356.  if cn>18 then cn:=18
  357. end;
  358.   end;
  359.  
  360.   function nofiles:boolean;
  361.   begin
  362.     if numuds=0 then begin
  363.       nofiles:=true;
  364.       writestr (^M'Sorry, no files!')
  365.     end else nofiles:=false
  366.   end;
  367.   Function capfir(inString:STRING):STRING;
  368.  begin
  369.    capfir:=upcase(inString[1]);
  370.  end;
  371.  
  372.  
  373.   procedure listfiles (extended:boolean);
  374.   var cnt,max,r1,r2:integer;
  375.       non:boolean;
  376.   begin
  377.     if nofiles then exit;
  378.     clearscr;
  379.  
  380.     cn:=0;
  381.     non:=false;
  382.     max:=numuds;
  383.     thereare (max,'File','Files');
  384.     parserange (max,r1,r2);
  385.     if r1=0 then exit;
  386.    writeln;
  387.    topfileline;
  388.     for cnt:=r1 to r2 do begin
  389.      inc(cn);
  390.        if (cn>=18) and (non=false) then
  391.      begin
  392.       bottomfileline;
  393.       cn:=0;
  394.       writestr(^P'File Listings Comamnds ['^S'Q/'^R'Quit'^P']['^S'N/'^R'Non-stop'^P']['^S'CR/'^R'Continue'^P']: *');
  395.       if capfir(input)='Q' then exit;
  396.       if capfir(input)='N' then non:=true;
  397.       topfileline;
  398.      end;
  399.       listfile (cnt,extended);
  400.       if break then exit
  401.     end;
  402.   bottomfileline;
  403.   end;
  404.  
  405.