home *** CD-ROM | disk | FTP | other *** search
/ The Devil's Doorknob BBS Capture (1996-2003) / devilsdoorknobbbscapture1996-2003.iso / Dloads / OTHERUTI / WWIV310S.ZIP / PART1.PAS < prev    next >
Pascal/Delphi Source File  |  1986-04-01  |  11KB  |  311 lines
  1.  
  2.                       {*****************************}
  3.                       {Copyright (c) 1986 Wayne Bell}
  4.                       {*****************************}
  5.  
  6. procedure printfile1(fn:str; var abort:boolean);
  7. var fil:text;
  8.     i:str;
  9.     next:boolean;
  10. begin
  11.  if not hangup then begin
  12.   assign(fil,fn);
  13.   {$I-} reset(fil); {$I+}
  14.   if ioresult<>0 then print('File not found.') else begin
  15.     abort:=false;
  16.     while not eof(fil) and (not abort) and (not hangup) do begin
  17.       readln(fil,i);
  18.       printa(i,abort,next);
  19.     end;
  20.     close(fil);
  21.   end;
  22.   nl;nl;
  23.  end;
  24. end;
  25.  
  26. procedure printfile(fn:str);
  27. var fil:text;
  28.     i:str;
  29.     abort,next:boolean;
  30. begin
  31.  if not hangup then begin
  32.   assign(fil,fn);
  33.   {$I-} reset(fil); {$I+}
  34.   if ioresult<>0 then print('File not found.') else begin
  35.     abort:=false;
  36.     while not eof(fil) and (not abort) and (not hangup) do begin
  37.       readln(fil,i);
  38.       printacr(i,abort,next);
  39.     end;
  40.     close(fil);
  41.   end;
  42.   nl;nl;
  43.  end;
  44. end;
  45.  
  46. procedure inli(var i:str);
  47. var cp,rp:integer; c:char; cv,cc:integer;
  48. begin
  49.   rp:=1; cp:=1;
  50.   i:='';
  51.   if ll<>'' then begin prompt(ll); i:=ll; ll:=''; cp:=length(i)+1; rp:=cp;end;
  52.   repeat
  53.     getkey(c); skey(c);
  54.     case ord(c) of
  55.       32..126:if (cp<strlen) and (rp<thisuser.linelen) then begin
  56.                 i[cp]:=c; cp:=cp+1; rp:=rp+1; outkey(c); thisline:=thisline+c;
  57.               end;
  58.             127,8:if cp>1 then begin c:=chr(8);
  59.                 if i[cp-1]=chr(8) then begin prompt(' '); rp:=rp+1; end else
  60.                  if i[cp-1]<>chr(10) then
  61.                    begin prompt(c+' '+c); rp:=rp-1; end;
  62.                 cp:=cp-1;
  63.               end;
  64.            26:phelp;
  65.            24:begin
  66.                 cp:=1; for cv:=1 to rp-1 do prompt(chr(8)+' '+chr(8));
  67.                 rp:=1;
  68.               end;
  69.            23:if cp>1 then repeat
  70.                 prompt(chr(8)+' '+chr(8)); rp:=rp-1; cp:=cp-1;
  71.               until (cp=1) or (i[cp]=' ') or (i[cp]=chr(8));
  72.            14:if (not (rbackspace in thisuser.ac)) and (rp>1) and (cp<strlen) then begin
  73.                 prompt(chr(8)); i[cp]:=chr(8); cp:=cp+1; rp:=rp-1;
  74.               end;
  75.            10:if (not (rbackspace in thisuser.ac)) and (cp<strlen) then begin
  76.                 prompt(c); i[cp]:=c; cp:=cp+1;
  77.               end;
  78.             9:begin
  79.                 cv:=5-(cp mod 5); if (cp+cv<strlen) and (rp+cv<thisuser.linelen) then
  80.                   for cc:=1 to cv do begin
  81.                     rp:=rp+1; prompt(' ');
  82.                     i[cp]:=' '; cp:=cp+1;
  83.                   end;
  84.               end;
  85.   end;
  86.   until (c=chr(13)) or ((rp=thisuser.linelen) and (wordwrap in thisuser.defaults)) or hangup;
  87.   i[0]:=chr(cp-1);
  88.   if c<>chr(13) then begin
  89.     cv:=cp-1;
  90.     while (cv>0) and (i[cv]<>' ') and (i[cv]<>chr(8))do cv:=cv-1;
  91.     if (cv>(rp div 2)) and (cv<>cp-1) then begin
  92.       ll:=copy(i,cv+1,cp-cv); for cc:=cp-2 downto cv do prompt(chr(8));
  93.       for cc:=cp-2 downto cv do prompt(' ');
  94.       i[0]:=chr(cv-1);
  95.     end;
  96.   end;
  97.   nl;
  98.   if c=chr(13) then i:=i+chr(1);
  99. end;
  100.  
  101. function filename(mrec:messages):str;
  102. begin
  103.   filename:='msgs\'+mrec.ltr+cstr(mrec.number)+'.'+cstr(mrec.ext);
  104. end;
  105.  
  106. procedure inmsg(var mrec:messages;an:anontyp;var title:str;tr,mp:boolean);
  107. var li:array[1..75] of str; t1,t,maxli,lc:integer; filler,spc,ti,i:str;
  108. saveline,exit,save,abortit:boolean; c:char; filvar:text;
  109.  
  110.   procedure listit(linenum:boolean);
  111.   var l:integer; abort,next:boolean;
  112.   begin
  113.     l:=1;
  114.     abort:=false;
  115.     while (l<>lc) and (not abort) do begin
  116.       if linenum then print(cstr(l)+':');
  117.       printa(li[l],abort,next);
  118.       if pap<>0 then nl;
  119.       l:=l+1;
  120.     end;
  121.     print('---===> Total lines: '+cstr(lc-1));
  122.     saveline:=false;
  123.   end;
  124.  
  125. begin
  126.  helpl:='F';lc:=1;spc:='                                                                              ';
  127.  filler:='-------------------------------------------------------------------------------';
  128.  ll:=''; if thisuser.sl<45 then maxli:=30 else if thisuser.sl<60 then
  129.    maxli:=50 else if thisuser.sl<80 then maxli:=60 else maxli:=75;
  130.  if tr then begin
  131.    repeat
  132.      print('       (---=----=----=----=----=----)');
  133.      prompt('Title? '); inputl(title,30);
  134.      if title<>'' then begin prompt('Ok? '); c:='N'; if yn then c:='Y'; end else c:='Y';
  135.    until (c='Y') or hangup;
  136.  end else begin
  137.    print('       (---=----=----=----=----=----)');
  138.    prompt('Title? '); inputl(title,30);
  139.  end;
  140.  if (title<>'') or not tr then begin
  141.   print('Enter message now, max '+cstr(maxli)+' lines.');
  142.   print('Enter "/HELP" for help');
  143.   print(copy('[---=----=----=----=----=----=----=----]----=----=----=----=----=----=----=----]',
  144.     1,thisuser.linelen));
  145.  repeat
  146.   repeat
  147.     saveline:=true; exit:=false; save:=false; abortit:=false;
  148.     inli(i); ti:=copy(i,1,3);
  149.     ti[1]:=upcase(ti[1]); ti[2]:=upcase(ti[2]); ti[3]:=upcase(ti[3]);
  150.     if (ti='/RL') and (lc>1) then begin print('Replace:'); saveline:=false; lc:=lc-1; end;
  151.     if ti='/EX' then begin exit:=true; saveline:=false; end;
  152.     if ti='/ES' then begin exit:=true; save:=true; saveline:=false; end;
  153.     if ti='/C:' then begin
  154.       i:=copy(i,4,length(i)-3);
  155.       if i[length(i)]<>#1 then i:=i+#1;
  156.       i:=#2+i;
  157.     end;
  158.     if (ti='/T:') and (maxli-lc>2) then begin
  159.       i:=copy(i,4,length(i)-3);
  160.       if i[length(i)]=#1 then i:=copy(i,1,length(i)-1);
  161.       li[lc]:=#2+'+-'+copy(filler,1,length(i))+'-+'+#1;
  162.       li[lc+1]:=#2+'! '+i+' !'+#1;
  163.       li[lc+2]:=li[lc];
  164.       saveline:=false; lc:=lc+3;
  165.     end;
  166.     if ti='/AB' then if upcase(i[4])='T'then begin
  167.       exit:=true; abortit:=true; saveline:=false; end;
  168.     if ti='/CL' then if upcase(i[4])='R' then begin
  169.       saveline:=false; lc:=1;
  170.       print('Message cleared.... Start over...');
  171.     end;
  172.     if ti='/HE' then begin
  173.       print('/ES = immediate save');
  174.       print('/EX = exit and edit');
  175.       print('/ABT = abort');
  176.       print('/CLR = clear message');
  177.       print('/LI = list so far');
  178.       print('/RL = replace last line');
  179.       print('/C: = center rest of line');
  180.       print('/T: = boxed title');
  181.       saveline:=false;
  182.     end;
  183.     if ti='/LI' then begin
  184.       prompt('With line numbers? '); if yn then listit(true) else listit(false);
  185.     end;
  186.     if saveline then begin li[lc]:=i; lc:=lc+1; if lc>maxli then exit:=true;
  187.       if lc+4=maxli then print('=5 lines left =');
  188.     end;
  189.   until exit or hangup;
  190.   if hangup then abortit:=true;
  191.   if (not abortit) and (not save) then
  192.   repeat
  193.     prompt('S,L,A,C,R,I,D,? :'); ONEK(c,'SLACRID?');
  194.     case c of
  195.       'L':begin prompt('With line numbers? '); if yn then listit(true) else listit(false); end;
  196.       'D':begin
  197.             prompt('Line number to delete (1-'+cstr(lc-1)+')? ');
  198.             input(i,4);t:=value(i); if (t>0) and (t<lc) then begin
  199.               for t1:=t to lc-2 do li[t1]:=li[t1+1]; lc:=lc-1;
  200.             end;
  201.           end;
  202.       'R':begin
  203.             prompt('Line number to replace (1-'+cstr(lc-1)+')? ');
  204.             input(i,4);t:=value(i); if (t>0) and (t<lc) then begin
  205.               print('Old line:'); print(li[t]); print('Enter new line:');
  206.               inli(i); if (li[t][length(li[t])]=#1) and (i[length(i)]<>#1) then
  207.                 li[t]:=i+#1 else li[t]:=i;
  208.             end;
  209.           end;
  210.       'I':begin
  211.             prompt('Line number to insert before (1-'+cstr(lc-1)+')? ');
  212.             input(i,4); t:=value(i); if (t>0) and (t<lc) then begin
  213.               for t1:=lc downto t+1 do li[t1]:=li[t1-1]; lc:=lc+1;
  214.               print('New line:'); inli(li[t]);
  215.             end;
  216.           end;
  217.       'A':begin
  218.             prompt('Abort? ');
  219.             if yn then abortit:=true else c:=' ';
  220.           end;
  221.       'S':save:=true;
  222.       'C':if lc>maxli then begin print('Too long.'); c:=' '; end else
  223.             print('Continue...');
  224.       '?':begin
  225.             print('S:ave         L:ist');
  226.             print('A:bort        C:ontinue');
  227.             print('R:eplace line I:nsert line');
  228.             print('D:elete line  ?:this');
  229.           end;
  230.     end;
  231.   until (c='S') or (c='A') or (c='C') or hangup;
  232.  until abortit or save or hangup;
  233.  if lc=1 then begin abortit:=true; save:=false; end;
  234.  if save then begin
  235.    case an of
  236.      no      : ti:=nam;
  237.      forced  : ti:='@'+nam;
  238.      yes     : begin
  239.                  prompt('Anonymous? ');
  240.                  if yn then ti:='@'+nam else ti:=nam;
  241.                end;
  242.      dearabby: begin repeat
  243.                  nl;print('Post as:'); print('1. Abby');
  244.                  print('2. Problemed Person'); print('3. '+nam);
  245.                  nl;prompt('Which? '); onek(c,'123');
  246.                 until (c in ['1'..'3']) or hangup;
  247.                 case c of
  248.                  '1': ti:='+'+nam;
  249.                  '2': ti:='-'+nam;
  250.                  '3': ti:=nam;
  251.                 end;
  252.                end;
  253.    end;
  254.    if ti=nam then lan:=false else lan:=true;
  255.    print('Saving...');
  256.    while (lc>1) and ((li[lc-1]='') or (li[lc-1]=chr(10))) do lc:=lc-1;
  257.    mrec:=systat.hmsg; mrec.number:=mrec.number+1; if mrec.number=-32767 then
  258.      mrec.ltr:=succ(mrec.ltr);
  259.    if mrec.ltr>'Z' then begin
  260.      mrec.ltr:='A';
  261.      mrec.ext:=mrec.ext+1;
  262.      if mrec.ext>=128 then mrec.ext:=1;
  263.    end;
  264.    systat.hmsg:=mrec;
  265.    if mp then mrec.ext:=mrec.ext+128;
  266.    i:=filename(mrec);
  267.    assign(filvar,i);
  268.    rewrite(filvar);
  269.    writeln(filvar,ti); ti:=dat; writeln(filvar,ti);
  270.    if irt<>'' then begin
  271.      writeln(filvar,'RE: '+irt);
  272.      writeln(filvar); writeln(filvar); writeln(filvar);
  273.    end;
  274.    for t:=1 to lc-1 do
  275.      writeln(filvar,li[t]);
  276.    close(filvar); reset(systatf); write(systatf,systat); close(systatf);
  277.  end else begin print('Aborted.'); mrec.ext:=0; end;
  278.  end else begin print('Aborted.'); mrec.ext:=0; end;
  279. end;
  280.  
  281. procedure readmsg(mrec:messages;rname:boolean; var next:boolean);
  282. var f,n,rn,d:str; filvar:text; abort:boolean;
  283. begin
  284.   lastname:='';
  285.   f:=filename(mrec); rn:='';
  286.   if cs then print('Filename: '+f);
  287.   assign(filvar,f); {$I-} reset(filvar); {$I+}
  288.   if ioresult<>0 then print('File not found.') else
  289.   if (not hangup) then begin
  290.     readln(filvar,n);
  291.     readln(filvar,d); lastname:=n;
  292.     if n[1]='@' then if rname then n:='<<< '+copy(n,2,length(n)-1)+' >>>'
  293.       else begin lastname:=''; n:='>UNKNOWN<'; d:='<-> INACTIVE <->'; END;
  294.     IF (N[1]='+') or (n[1]='-') then begin
  295.       rn:=copy(n,2,length(n)-1);
  296.       if n[1]='+' then n:='Abby' else n:='Problemed Person';
  297.       if not rname then begin d:='<-> INACTIVE <->'; rn:=''; lastname:=''; end;
  298.     end;
  299.     abort:=false;
  300.     printacr('Name: '+n,abort,next); if not abort then begin
  301.       if  rn<>'' then print('Name: '+rn);
  302.       printacr('Date: '+d,abort,next); nl;
  303.       while (not abort) and (not eof(filvar)) do begin
  304.         readln(filvar,n); printa(n,abort,next);
  305.       end;
  306.       if not abort then nl;
  307.     end;
  308.   end;
  309.   close(filvar); nl;
  310. end;
  311.