diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 0000000..d6cc955 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,22 @@ + + +2000-11-17 Ryan C. Gordon + + * Initial work. + + * Wrote Makefile. + + * filenames -> lowercase, dos2unix'd them. + + * Stubbed offending DOSisms, like direct video writes and serial port i/o. + + * Commented out "uses overlay" commands. + + * Renamed newcommm.pas to newcom.pas ... + + * Fixed some other syntax stuff that doesn't fly under Free Pascal. + + +// end of CHANGELOG ... + + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..a42fed2 --- /dev/null +++ b/Makefile @@ -0,0 +1,112 @@ +#--------------------------------------------------------------------------- +# Makefile by Ryan C. Gordon (icculus@lokigames.com) +#--------------------------------------------------------------------------- + +# should be 386, mmx, 686, or other. +# +# 386 and 486 chips use "386" +# Pentiums, Celerons, PentiumMMX should use "mmx" +# PentiumPro, PII, PIII, K6, Cyrix686/MII, Athlon, etc. should use "686" +# PowerPC and other non-x86 chips should use "other" +cpu=686 + +# Are you debugging? Specify "true". Release binaries? "false". +debug=true + +# want to see more verbose compiles? Set this to "true". +verbose=true + +# You probably don't need to touch this one. This is the location of +# your copy of PPC386, if it's not in the path. +# Get this from http://www.freepascal.org/ ... +PPC386=ppc386 + +#--------------------------------------------------------------------------- +# don't touch anything below this line. + +# This is the name of the produced binary. "bbs" should suffice. +MAINEXE=bbs + +ifeq ($(strip $(verbose)),true) + PPC386FLAGS += -vwnh +endif + +ifeq ($(strip $(debug)),true) + BUILDDIR := $(cpu)/Debug + PPC386FLAGS += -g # include debug symbols. + PPC386FLAGS += -gc # generate checks for pointers. + PPC386FLAGS += -Ct # generate stack-checking code. + PPC386FLAGS += -Cr # generate range-checking code. + PPC386FLAGS += -Co # generate overflow-checking code. + PPC386FLAGS += -Ci # generate I/O-checking code. +else + BUILDDIR := $(cpu)/Release + PPC386FLAGS += -Xs # strip the binary. + PPC386FLAGS += -O2 # Level 2 optimizations. + PPC386FLAGS += -OG # Optimize for speed, not size. + + ifeq ($(strip $(cpu)),386) + PPC386FLAGS += -OP1 + else + ifeq ($(strip $(cpu)),mmx) + PPC386FLAGS += -OP2 + else + ifeq ($(strip $(cpu)),686) + PPC386FLAGS += -OP3 + endif + endif + endif +endif + +# Borland TP7.0 compatibility flag. +PPC386FLAGS += -So + +# Support C-style macros. +#PPC386FLAGS += -Sm + +# Assembly statements are Intel-like (instead of AT&T-like). +PPC386FLAGS += -Rintel + +# Dynamic linkage. +PPC386FLAGS += -XD + +# Output target Linux. !!! FIXME: Want win32 compiles? +PPC386FLAGS += -TLINUX + +# Smartlink the binary, removing unused code. +PPC386FLAGS += -CX + +# Pipe output to assembler, rather than to temp file. This is a little faster. +PPC386FLAGS += -P + +# Write bins to this directory... +PPC386FLAGS += -FE$(BUILDDIR) + +#--------------------------------------------------------------------------- +# Build rules...don't touch this, either. + +include sources + +OBJSx := $(SRCS:.pas=.o) +OBJS := $(foreach feh,$(OBJSx),$(BUILDDIR)/$(feh)) + +$(BUILDDIR)/%.o : %.pas + $(PPC386) $(PPC386FLAGS) $< + +all: $(MAINEXE) + +$(MAINEXE) : $(BUILDDIR) $(OBJS) bbs.pas + $(PPC386) $(PPC386FLAGS) bbs.pas + +$(BUILDDIR): $(cpu) + mkdir $(BUILDDIR) + +$(cpu): + mkdir $(cpu) + +clean: + rm -rf $(BUILDDIR) + rm -rf core + +# end of Makefile ... + diff --git a/a.bat b/a.bat new file mode 100644 index 0000000..2cea182 --- /dev/null +++ b/a.bat @@ -0,0 +1,3 @@ +@echo off +echo  +tasm %1 %2 %3 %4 %5 %6 diff --git a/amake.bat b/amake.bat new file mode 100644 index 0000000..26510b3 --- /dev/null +++ b/amake.bat @@ -0,0 +1,4 @@ +@echo off +copy mabs.pas mabs%1.pas +call c mabs%1 /DAS%1 +del mabs%1.pas diff --git a/archive1.pas b/archive1.pas new file mode 100644 index 0000000..dcb94e8 --- /dev/null +++ b/archive1.pas @@ -0,0 +1,555 @@ +{$A+,B+,D-,E+,F+,I+,L-,N-,O+,R-,S+,V-} +unit archive1; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + execbat, + common; + +procedure purgedir(s:astr); {* erase all non-dir files in dir *} +function arcmci(src,fn,ifn:astr):astr; +procedure arcdecomp(var ok:boolean; atype:integer; fn,fspec:astr); +procedure arccomp(var ok:boolean; atype:integer; fn,fspec:astr); +procedure arccomment(var ok:boolean; atype,cnum:integer; fn:astr); +procedure arcintegritytest(var ok:boolean; atype:integer; fn:astr); +procedure conva(var ok:boolean; otype,ntype:integer; tdir,ofn,nfn:astr); +function arctype(s:astr):integer; +procedure listarctypes; +procedure invarc; +procedure extracttotemp; +procedure userarchive; + +implementation + +uses file0, file1, file2, file4, file7, file9, file11; + +const + maxdoschrline=127; + +procedure purgedir(s:astr); {* erase all non-dir files in dir *} +var odir,odir2:astr; + dirinfo:searchrec; + f:file; + att:word; +begin + s:=fexpand(s); + while copy(s,length(s),1)='\' do s:=copy(s,1,length(s)-1); + getdir(0,odir); getdir(exdrv(s),odir2); + chdir(s); + findfirst('*.*',AnyFile-Directory,dirinfo); + while (doserror=0) do begin + assign(f,fexpand(dirinfo.name)); + setfattr(f,$00); {* remove possible read-only, etc, attributes *} + {$I-} erase(f); {$I+} {* erase the $*@( file !! *} + findnext(dirinfo); {* move on to the next one... *} + end; + chdir(odir2); chdir(odir); +end; + +function arcmci(src,fn,ifn:astr):astr; +begin + src:=substall(src,'@F',fn); + src:=substall(src,'@I',ifn); + arcmci:=src; +end; + +procedure arcdecomp(var ok:boolean; atype:integer; fn,fspec:astr); +begin + purgedir(systat.temppath+'1\'); + + shel1; + execbatch(ok,TRUE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'1\', + arcmci(systat.filearcinfo[atype].unarcline,fn,fspec), + systat.filearcinfo[atype].succlevel); + shel2; + + if (not ok) then + sysoplog('Archive "'+fn+'": Errors during de-compression'); +end; + +procedure arccomp(var ok:boolean; atype:integer; fn,fspec:astr); +{* ok: result + * atype: archive method + * fn : archive filename + *} +begin + shel1; + execbatch(ok,TRUE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'1\', + arcmci(systat.filearcinfo[atype].arcline,fn,fspec), + systat.filearcinfo[atype].succlevel); + shel2; + + if (not ok) then + sysoplog('Archive "'+fn+'": Errors during compression'); + + purgedir(systat.temppath+'1\'); +end; + +procedure arccomment(var ok:boolean; atype,cnum:integer; fn:astr); +var ff:text; + tfn:astr; + b:boolean; +begin + if (cnum<>0) and (systat.filearccomment[cnum]<>'') then begin + tfn:=fexpand('tgtemp2.$$$'); + assign(ff,tfn); rewrite(ff); + writeln(ff,systat.filearccomment[cnum]); close(ff); + + shel1; + b:=systat.swapshell; systat.swapshell:=FALSE; + execbatch(ok,FALSE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'1\', + arcmci(systat.filearcinfo[atype].cmtline,fn,'')+' <'+tfn, + systat.filearcinfo[atype].succlevel); + systat.swapshell:=b; + shel2; + + erase(ff); + end; +end; + +procedure arcintegritytest(var ok:boolean; atype:integer; fn:astr); +begin + if (systat.filearcinfo[atype].testline<>'') then begin + shel1; + execbatch(ok,TRUE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'1\', + arcmci(systat.filearcinfo[atype].testline,fn,''), + systat.filearcinfo[atype].succlevel); + shel2; + end; +end; + +procedure conva(var ok:boolean; otype,ntype:integer; tdir,ofn,nfn:astr); +var f:file; + nofn,ps,ns,es:astr; + eq:boolean; +begin + star('Converting archive - stage one.'); + eq:=(otype=ntype); + if (eq) then begin + fsplit(ofn,ps,ns,es); + nofn:=ps+ns+'.#$%'; + end; + arcdecomp(ok,otype,ofn,'*.*'); + if (not ok) then star('Errors in decompression!') + else begin + star('Converting archive - stage two.'); + if (eq) then begin assign(f,ofn); rename(f,nofn); end; + arccomp(ok,ntype,nfn,'*.*'); + if (not ok) then begin + star('Errors in compression!'); + if (eq) then begin assign(f,nofn); rename(f,ofn); end; + end; + if (not exist(sqoutsp(nfn))) then ok:=FALSE; + end; +end; + +function arctype(s:astr):integer; +var atype:integer; +begin + s:=align(stripname(s)); s:=copy(s,length(s)-2,3); + atype:=1; + while (systat.filearcinfo[atype].ext<>'') and + (systat.filearcinfo[atype].ext<>s) and + (atype'') and (ilng) then begin + nl; + print('You have exceeded this limit.'); + nl; + print('Please remove some files from the TEMP directory using'); + print('the user-archive command to free up some space.'); + exit; + end; + end; + + nl; + prt('Filename: '); + if (fso) then input(s,69) else input(s,12); + if (hangup) then exit; + if (s<>'') then begin + if ((isul(s)) and (not fso)) then begin + nl; + print('Invalid filename.'); + end else begin + if (pos('.',s)=0) then s:=s+'*.*'; + + ok:=TRUE; abort:=FALSE; next:=FALSE; + if (not isul(s)) then begin + recno(s,pl,rn); { loads memuboard ... } + ok:=(rn<>0); + if (ok) then begin + seek(ulff,rn); read(ulff,f); + fn:=fexpand(memuboard.dlpath+sqoutsp(f.filename)); + ok:=(okdl(f)); + end else + print('File not found: "'+s+'"'); + end else begin + fn:=fexpand(s); + ok:=(exist(fn)); + if (ok) then begin + assign(fi,fn); + {$I-} reset(fi); {$I+} + if (ioresult<>0) then print('Error accessing file.') + else begin + with f do begin + filename:=align(stripname(fn)); + description:='Unlisted file.'; + filepoints:=0; + nacc:=0; + ft:=255; + blocks:=trunc((filesize(fi)+127.0)/128.0); + owner:=usernum; + stowner:=caps(thisuser.name); + vpointer:=-1; + filestat:=[]; + end; + f.date:=date; + f.daten:=daynum(date); + end; + end else + print('File not found: "'+fn+'"'); + end; + fsplit(fn,ps,ns,es); + + if (ok) then begin + toextract:=TRUE; tocopy:=FALSE; + atype:=arctype(fn); + if (atype=0) then begin + nl; + print('Unsupported archive format.'); + listarctypes; + toextract:=FALSE; + end; + nl; + print('You can (C)opy this file into the TEMP directory,'); + if (toextract) then begin + print('or (E)xtract files FROM it into the TEMP directory.'); + nl; prt('Which? (CE,Q=Quit) : '); onek(c,'QCE'); + end else begin + print('but you can''t extract files from it.'); + nl; prt('Which? (C,Q=Quit) : '); onek(c,'QC'); + end; + nl; + if (hangup) then exit; + case c of + 'C':tocopy:=TRUE; + 'E':toextract:=TRUE; + else begin + tocopy:=FALSE; + toextract:=FALSE; + end; + end; + if (tocopy) then toextract:=FALSE; + if (toextract) then begin + nl; fileinfo(f,FALSE,abort,next); nl; + done:=FALSE; + repeat + prt('Extract files (=All,V=View,Q=Quit) : '); input(s,12); + if (hangup) then exit; + abort:=FALSE; next:=FALSE; + if (s='') then s:='*.*'; + if (s='V') then begin + abort:=FALSE; next:=FALSE; + if (isul(fn)) then lfi(fn,abort,next) else lfin(rn,abort,next); + end + else + if (s='Q') then done:=TRUE + else begin + if (isul(s)) then print('Illegal filespec.') + else begin + ok:=TRUE; + s:=sqoutsp(s); + shel1; + execbatch(ok,TRUE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'3\', + arcmci(systat.filearcinfo[atype].unarcline,fn,s), + systat.filearcinfo[atype].succlevel); + shel2; + + if (not ok) then begin + sysoplog('Archive "'+fn+'": Errors during user decompression'); + star('Errors in decompression!'); + nl; + end else + sysoplog('User decompressed "'+s+'" into TEMP from "'+fn+'"'); + if (ok) then didsomething:=TRUE; + end; + end; + until (done) or (hangup); + end; + if (tocopy) then begin + s:=systat.temppath+'3\'+ns+es; (*sqoutsp(f.filename);*) + sprompt(#3#5+'Progress: '); + copyfile(ok,nospace,TRUE,fn,s); + if (ok) then + sprint(#3#5+' - Copy successful.') + else + if (nospace) then + sprint(#3#7+'Copy unsuccessful - insufficient space!') + else + sprint(#3#7+'Copy unsuccessful!'); + sysoplog('User copied "'+fn+'" into TEMP directory.'); + if (ok) then didsomething:=TRUE; + end; + if (didsomething) then begin + nl; + print('Use the user archive menu command to access'); + print('files in the TEMP directory.'); + end; + end; + end; + end; +end; + +procedure userarchive; +var fi:file of byte; + f:ulfrec; + su:ulrec; + s,s1,fn,savpath:astr; + pl,atype,gotpts,oldnumbatchfiles:integer; + c:char; + abort,next,done,ok,savefileptratio:boolean; + + function okname(s:astr):boolean; + begin + okname:=TRUE; + okname:=not iswildcard(s); + if (isul(s)) then okname:=FALSE; + end; + +begin + nl; + done:=FALSE; + repeat + prt('Temp archive menu (?=help) : '); + onek(c,'QADLRVT?'); + case c of + 'Q':done:=TRUE; + '?':begin + nl; + listarctypes; + nl; + lcmds(30,3,'Add to archive',''); + lcmds(30,3,'Download files',''); + lcmds(30,3,'List files in directory',''); + lcmds(30,3,'Remove files',''); + lcmds(30,3,'Text view file',''); + lcmds(30,3,'View archive',''); + lcmds(30,3,'Quit',''); + nl; + end; + 'A':begin + nl; prt('Archive name: '); input(fn,12); + if (hangup) then exit; + fn:=systat.temppath+'3\'+fn; + loaduboard(fileboard); + if (pos('.',fn)=0) and (memuboard.arctype<>0) then + fn:=fn+'.'+systat.filearcinfo[memuboard.arctype].ext; + atype:=arctype(fn); + if (atype=0) then begin + nl; + print('Archive format not supported.'); + listarctypes; + nl; + end else begin + prt('File mask: '); input(s,12); + if (hangup) then exit; + if (isul(s)) then print('Illegal file mask.') + else + if (s<>'') then begin + nl; + ok:=TRUE; + shel1; + execbatch(ok,TRUE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'3\', + arcmci(systat.filearcinfo[atype].arcline,fn,s), + systat.filearcinfo[atype].succlevel); + shel2; + if (not ok) then begin + sysoplog('Archive "'+fn+'": Errors during user compression'); + star('Errors in compression!'); + nl; + end else + sysoplog('User compressed "'+s+'" into "'+fn+'"'); + end; + end; + end; + 'D':begin + nl; prt('Filename: '); input(s,12); + if (hangup) then exit; + if (not okname(s)) then print('Illegal filename.') + else begin + s:=systat.temppath+'3\'+s; + assign(fi,s); + {$I-} reset(fi); {$I+} + if (ioresult=0) then begin + f.blocks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + if (f.blocks<>0) then begin + savefileptratio:=systat.fileptratio; + if ((not systat.uldlratio) and + (not systat.fileptratio)) then + systat.fileptratio:=TRUE; + + doffstuff(f,stripname(s),gotpts); + + systat.fileptratio:=savefileptratio; + + with f do begin + description:='Temporary file'; + ft:=255; + vpointer:=-1; + filestat:=[]; + end; + + fiscan(pl); { loads in memuboard } + su:=memuboard; + with memuboard do begin + dlpath:=systat.temppath+'3\'; + ulpath:=systat.temppath+'3\'; + name:='Temporary directory'; + fbstat:=[]; + end; + + oldnumbatchfiles:=numbatchfiles; + dlx(f,-1,abort); + + memuboard:=su; + close(ulff); + + if (numbatchfiles<>oldnumbatchfiles) then begin + nl; + sprint(#3#5+'REMEMBER: If you delete this file from the temporary directory,'); + sprint(#3#5+'you will not be able to download it in your batch queue.'); + end; + end; + end; + nl; + end; + end; + 'L':begin + nl; + dir(systat.temppath+'3\','*.*',TRUE); + nl; + end; + 'R':begin + nl; prt('File mask: '); input(s,12); + if (hangup) then exit; + if (isul(s)) then print('Illegal filename.') + else begin + s:=systat.temppath+'3\'+s; + ffile(s); + if (not found) then + print('File not found.') + else + repeat + if not ((dirinfo.attr and VolumeID=VolumeID) or + (dirinfo.attr and Directory=Directory)) then begin + s:=dirinfo.name; + assign(fi,systat.temppath+'3\'+s); + {$I-} erase(fi); {$I+} + if (ioresult<>0) then begin + sysoplog('Error removing from temp. dir: "'+s+'"'); + print('Error erasing "'+s+'"'); + end else + sysoplog('User removed from temp. dir: "'+s+'"'); + end; + nfile; + until (not found); + end; + nl; + end; + 'T':begin + nl; prt('Filename: '); input(s,12); + if (hangup) then exit; + if (not okname(s)) then print('Illegal filename.') + else begin + s1:=systat.temppath+'3\'+s; + if (not exist(s1)) then + print('File not found.') + else begin + sysoplog('User ASCII viewed in temp. dir: "'+s+'"'); + nl; + sendascii(s1); + end; + end; + end; + 'V':begin + nl; prt('File mask: '); input(fn,12); + if (hangup) then exit; + abort:=FALSE; next:=FALSE; + ffile(systat.temppath+'3\'+fn); + repeat + lfi(systat.temppath+'3\'+dirinfo.name,abort,next); + nfile; + until (not found) or (abort) or (hangup); + end; + end; + until ((done) or (hangup)); + lastcommandovr:=TRUE; +end; + +end. diff --git a/archive2.pas b/archive2.pas new file mode 100644 index 0000000..9937d8f --- /dev/null +++ b/archive2.pas @@ -0,0 +1,684 @@ +{$A+,B+,D-,E+,F+,I+,L-,N-,O+,R-,S+,V-} +unit archive2; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + archive1, file0, file1, file4, file9, file11, + execbat, + common; + +procedure doarccommand(cc:char); + +implementation + +const + maxdoschrline=127; + +procedure doarccommand(cc:char); +const maxfiles=100; +var fl:array[1..maxfiles] of astr; + fn,s,s1,s2,os1:astr; + atype,numfl,rn,pl,savflistopt:integer; + i,j,x:integer; + c:char; + abort,next,done,ok,ok1:boolean; + fnx:boolean; {* whether fn points to file out of Telegard .DIR list *} + fil1,fil2:boolean; {* whether listed/unlisted files in list *} + wenttosysop,delbad,savpause:boolean; + f,f1:ulfrec; + rfpts:real; + fi:file of byte; + v:verbrec; + dstr,nstr,estr:astr; + bb:byte; + c_files,c_oldsiz,c_newsiz,oldsiz,newsiz:longint; + + function stripname(i:astr):astr; + var i1:astr; n:integer; + + function nextn:integer; + var n:integer; + begin + n:=pos(':',i1); + if (n=0) then n:=pos('\',i1); + if (n=0) then n:=pos('/',i1); + nextn:=n; + end; + + begin + i1:=i; + while nextn<>0 do i1:=copy(i1,nextn+1,80); + stripname:=i1; + end; + + procedure addfl(fn:astr; b:boolean); + var pl,rn,oldnumfl:integer; + f:ulfrec; + s,dstr,nstr,estr:astr; + dirinfo:searchrec; + begin + if (not b) then begin + oldnumfl:=numfl; + recno(fn,pl,rn); + if (fn<>'') and (pos('.',fn)<>0) and (rn<>0) then + while (fn<>'') and (rn<>0) and (numfl=maxfiles) then print('File records filled.'); + end else begin + oldnumfl:=numfl; + fsplit(fn,dstr,nstr,estr); s:=dstr; + while (copy(s,length(s),1)='\') do s:=copy(s,1,length(s)-1); + {$I-} chdir(s); {$I+} + if ioresult<>0 then print('Path not found.') + else begin + findfirst(fn,AnyFile-Directory-VolumeID,dirinfo); + while (doserror=0) and (numfl=maxfiles) then print('File records filled.'); + if (numfl=oldnumfl) then print('No matching files.'); + end; + chdir(start_dir); + end; + end; + + procedure testfiles(b:integer; fn:astr; delbad:boolean; var abort,next:boolean); + var fi:file of byte; + f:ulfrec; + oldboard,pl,rn,atype:integer; + ok:boolean; + begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + recno(fn,pl,rn); { loads in memuboard } + abort:=FALSE; next:=FALSE; + while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + fn:=memuboard.dlpath+f.filename; + atype:=arctype(fn); + if (atype<>0) then begin + pbn(abort,next); nl; + star('Testing "'+sqoutsp(fn)+'"'); + ok:=TRUE; + if (not exist(fn)) then begin + star('File "'+sqoutsp(fn)+'" doesn''t exist.'); + ok:=FALSE; + end else begin + arcintegritytest(ok,atype,sqoutsp(fn)); + if (not ok) then begin + star('File "'+sqoutsp(fn)+'" didn''t pass integrity test.'); + if (delbad) then begin + deleteff(rn,pl,TRUE); + assign(fi,fn); + {$I-} erase(fi); {$I+} + if (ioresult<>0) then star('Error erasing "'+sqoutsp(fn)+'"!'); + end; + end; + end; + end; + nrecno(fn,pl,rn); + wkey(abort,next); + end; + close(ulff); + end; + fileboard:=oldboard; + end; + + procedure cmtfiles(b:integer; fn:astr; var abort,next:boolean); + var fi:file of byte; + f:ulfrec; + oldboard,pl,rn,atype:integer; + ok:boolean; + begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + recno(fn,pl,rn); { loads in memuboard } + abort:=FALSE; next:=FALSE; + while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + fn:=memuboard.dlpath+f.filename; + atype:=arctype(fn); + if (atype<>0) then begin + pbn(abort,next); nl; + star('Commenting "'+sqoutsp(fn)+'"'); + ok:=TRUE; + if (not exist(fn)) then begin + star('File "'+sqoutsp(fn)+'" doesn''t exist.'); + ok:=FALSE; + end + else arccomment(ok,atype,memuboard.cmttype,sqoutsp(fn)); + end; + nrecno(fn,pl,rn); + wkey(abort,next); + end; + close(ulff); + end; + fileboard:=oldboard; + end; + + procedure cvtfiles(b:integer; fn:astr; toa:integer; + var c_files,c_oldsiz,c_newsiz:longint; + var abort,next:boolean); + var fi:file of byte; + f:ulfrec; + s:astr; + oldboard,pl,rn,atype:integer; + ok:boolean; + begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + recno(fn,pl,rn); { loads in memuboard } + abort:=FALSE; next:=FALSE; + while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + fn:=memuboard.dlpath+f.filename; + atype:=arctype(fn); + if (atype<>0) and (atype<>toa) then begin + pbn(abort,next); nl; + star('Converting "'+sqoutsp(fn)+'"'); + ok:=FALSE; + if (not exist(fn)) then + star('File "'+sqoutsp(fn)+'" doesn''t exist.') + else begin + ok:=TRUE; + s:=copy(fn,1,pos('.',fn))+systat.filearcinfo[toa].ext; + conva(ok,atype,bb,systat.temppath+'1\',sqoutsp(fn),sqoutsp(s)); + if (ok) then begin + assign(fi,sqoutsp(fn)); + {$I-} reset(fi); {$I+} + ok:=(ioresult=0); + if (ok) then begin + oldsiz:=trunc(filesize(fi)); + close(fi); + end else + star('Unable to access "'+sqoutsp(fn)+'"'); + if (ok) then + if (not exist(sqoutsp(s))) then begin + star('Unable to access "'+sqoutsp(s)+'"'); + sysoplog('Unable to access "'+sqoutsp(s)+'"'); + ok:=FALSE; + end; + end; + if (ok) then begin + f.filename:=align(stripname(sqoutsp(s))); + seek(ulff,rn); write(ulff,f); + {$I-} erase(fi); {$I+} + if (ioresult<>0) then begin + star('Unable to erase "'+sqoutsp(fn)+'"'); + sysoplog('Unable to erase "'+sqoutsp(fn)+'"'); + end; + + assign(fi,sqoutsp(s)); + {$I-} reset(fi); {$I+} + ok:=(ioresult=0); + if (not ok) then begin + star('Unable to access "'+sqoutsp(s)+'"'); + sysoplog('Unable to access "'+sqoutsp(s)+'"'); + end else begin + newsiz:=trunc(filesize(fi)); + f.blocks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + seek(ulff,rn); write(ulff,f); + end; + + if (ok) then begin + inc(c_oldsiz,oldsiz); + inc(c_newsiz,newsiz); + inc(c_files); + star('Old total space took up : '+cstrl(oldsiz)+' bytes'); + star('New total space taken up : '+cstrl(newsiz)+' bytes'); + if (oldsiz-newsiz>0) then + star('Space saved : '+cstrl(oldsiz-newsiz)+' bytes') + else + star('Space wasted : '+cstrl(newsiz-oldsiz)+' bytes'); + end; + end else begin + sysoplog('Unable to convert "'+sqoutsp(fn)+'"'); + star('Unable to convert "'+sqoutsp(fn)+'"'); + end; + end; + end; + nrecno(fn,pl,rn); + wkey(abort,next); + end; + close(ulff); + end; + fileboard:=oldboard; + end; + +begin + savpause:=(pause in thisuser.ac); + if (savpause) then thisuser.ac:=thisuser.ac-[pause]; + savflistopt:=thisuser.flistopt; thisuser.flistopt:=0; + numfl:=0; + fiscan(pl); { loads in memuboard } + case cc of + 'A':begin + nl; + print('Add file(s) to archive (up to '+cstr(maxfiles)+') -'); + nl; + print('Archive filename: '); + prt(':'); mpl(78); input(fn,78); + if (fn<>'') then begin + if (pos('.',fn)=0) and (memuboard.arctype<>0) then + fn:=fn+'.'+systat.filearcinfo[memuboard.arctype].ext; + fnx:=isul(fn); + if (not fnx) then fn:=memuboard.dlpath+fn; + fn:=fexpand(fn); atype:=arctype(fn); + if (atype=0) then begin + print('Archive format not supported.'); + listarctypes; + end else begin + done:=FALSE; c:='A'; + repeat + if (c='A') then + repeat + nl; + print('Add files to list - to end'); + prt(cstr(numfl)+':'); mpl(70); input(s,70); + if s<>'' then begin + if pos('.',s)=0 then s:=s+'*.*'; + addfl(s,isul(s)); + end; + until (s='') or (numfl>=maxfiles) or (hangup); + nl; + prt('Add files to list (?=help) : '); onek(c,'QADLR?'); + nl; + case c of + '?':begin + lcmds(19,3,'Add more to list','Do it!'); + lcmds(19,3,'List files in list','Remove files from list'); + lcmds(19,3,'Quit',''); + end; + 'D':begin + i:=0; + repeat + inc(i); j:=1; + s2:=sqoutsp(fl[i]); + if not isul(s2) then + s2:=memuboard.dlpath+s2; + s1:=arcmci(systat.filearcinfo[atype].arcline,fn,s2); + os1:=s1; + while (length(s1)<=maxdoschrline) and (imaxdoschrline) then begin + dec(i); dec(j); + s1:=os1; + end; + ok:=TRUE; + star('Adding '+cstr(j)+' files to archive...'); + shel1; + execbatch(ok,TRUE,'tgtemp1.bat','tgtemp1.$$$', + systat.temppath+'1\',s1, + systat.filearcinfo[atype].succlevel); + shel2; + if (not ok) then begin + star('Errors in adding files'); + ok:=pynq('Continue anyway? '); + if (hangup) then ok:=FALSE; + end; + until (i>=numfl) or (not ok); + arccomment(ok,atype,memuboard.cmttype,fn); + nl; + if (not fnx) then begin + s2:=stripname(fn); + recno(s2,pl,rn); + if (rn<>0) then + sprint(#3#5+'NOTE: File already exists in listing!'); + if pynq('Add archive to listing? ') then begin + assign(fi,fn); + {$I-} reset(fi); {$I+} + if ioresult=0 then begin + f.blocks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + end; + f.filename:=s2; + ok1:=TRUE; + if pynq('Use stats of file in directory? ') then begin + repeat + nl; + prt('Enter filename: '); mpl(12); input(s2,12); + recno(s2,pl,rn); + if rn=0 then print('File not found!'); + if s2='' then print('Aborted!'); + until (rn<>0) or (s2='') or (hangup); + if s2<>'' then begin + seek(ulff,rn); read(ulff,f1); + with f do begin + description:=f1.description; + vpointer:=f1.vpointer; + nacc:=f1.nacc; + ft:=f1.ft; + owner:=f1.owner; + stowner:=f1.stowner; + date:=f1.date; + daten:=f1.daten; + end; + f1.vpointer:=-1; + seek(ulff,rn); write(ulff,f1); + end else + ok1:=FALSE; + end else + ok1:=FALSE; + + if (not ok1) then begin + wenttosysop:=FALSE; + dodescrs(f,v,pl,wenttosysop); + f.nacc:=0; + f.ft:=255; + f.owner:=usernum; + f.stowner:=allcaps(thisuser.name); + f.date:=date; + f.daten:=daynum(date); + end; + + f.filestat:=[]; + if (not fso) and (not systat.validateallfiles) then + f.filestat:=f.filestat+[notval]; + + if (not systat.fileptratio) then f.filepoints:=0 + else begin + rfpts:=(f.blocks/8)/systat.fileptcompbasesize; + f.filepoints:=round(rfpts); + end; + + if (rn=0) then newff(f,v) else writefv(rn,f,v); + end; + end; + if pynq('Delete original files? ') then + for i:=1 to numfl do begin + s2:=sqoutsp(fl[i]); + if not isul(fl[i]) then begin + recno(s2,pl,rn); + if rn<>0 then deleteff(rn,pl,TRUE); + s2:=memuboard.dlpath+s2; + end; + assign(fi,s2); + {$I-} erase(fi); {$I+} + if (ioresult<>0) then + print('"'+s2+'": Could not delete'); + end; + if ok then done:=TRUE; + end; + 'L':if (numfl=0) then print('No files in list!') + else begin + abort:=FALSE; next:=FALSE; + s:=''; j:=0; + i:=0; + repeat + inc(i); + if isul(fl[i]) then s:=s+#3#3 else s:=s+#3#1; + s:=s+align(stripname(fl[i])); + inc(j); + if j<5 then s:=s+' ' + else begin + printacr(s,abort,next); + s:=''; j:=0; + end; + until (i=numfl) or (abort) or (hangup); + if (j in [1..4]) and (not abort) then + printacr(s,abort,next); + end; + 'R':begin + prt('Remove filename: '); mpl(12); input(s,12); + i:=0; + repeat + inc(i); + if align(stripname(fl[i]))=align(s) then begin + s1:=sqoutsp(fl[i]); sprompt(#3#3+s1); + if pynq(' Remove it? ') then begin + for j:=i to numfl-1 do fl[j]:=fl[j+1]; + dec(numfl); dec(i); + end; + end; + until (i>=numfl); + end; + 'Q':done:=TRUE; + end; + until (done) or (hangup); + + end; + end; + end; + 'C':begin + nl; + print('Convert archive formats -'); + nl; + print('Filespec:'); + prt(':'); mpl(78); input(fn,78); + c_files:=0; c_oldsiz:=0; c_newsiz:=0; + if (fn<>'') then begin + nl; + abort:=FALSE; next:=FALSE; + repeat + prt('Archive type to use? (?=List) : '); input(s,3); + if (s='?') then begin nl; listarctypes; nl; end; + until (s<>'?'); + if (value(s)<>0) then bb:=value(s) + else bb:=arctype(s+'FILENAME.'+s); + if (bb<>0) then begin + sysoplog('Conversion process began at '+date+' '+time+'.'); + if (isul(fn)) then begin + fsplit(fn,dstr,nstr,estr); s:=dstr; + findfirst(fn,AnyFile-Directory-VolumeID,dirinfo); + abort:=FALSE; next:=FALSE; + while (doserror=0) and (not abort) and (not hangup) do begin + fn:=fexpand(sqoutsp(dstr+dirinfo.name)); + atype:=arctype(fn); + if (atype<>0) and (atype<>bb) then begin + star('Converting "'+fn+'"'); + ok:=TRUE; + s:=copy(fn,1,pos('.',s))+systat.filearcinfo[bb].ext; + conva(ok,atype,bb,systat.temppath+'1\',fn,s); + if (ok) then begin + assign(fi,sqoutsp(fn)); + {$I-} reset(fi); {$I+} + ok:=(ioresult=0); + if (ok) then begin + oldsiz:=trunc(filesize(fi)); + close(fi); + end else + star('Unable to access "'+sqoutsp(fn)+'"'); + if (ok) then + if (not exist(sqoutsp(s))) then begin + star('Unable to access "'+sqoutsp(s)+'"'); + sysoplog('Unable to access "'+sqoutsp(s)+'"'); + ok:=FALSE; + end; + end; + if (ok) then begin + {$I-} erase(fi); {$I+} + if (ioresult<>0) then + star('Unable to erase "'+sqoutsp(fn)+'"'); + + assign(fi,sqoutsp(s)); + {$I-} reset(fi); {$I+} + ok:=(ioresult=0); + if (ok) then begin + newsiz:=trunc(filesize(fi)); + close(fi); + end else + star('Unable to access "'+sqoutsp(s)+'"'); + + if (ok) then begin + inc(c_oldsiz,oldsiz); + inc(c_newsiz,newsiz); + inc(c_files); + star('Old total space took up : '+cstrl(oldsiz)+' bytes'); + star('New total space taken up : '+cstrl(newsiz)+' bytes'); + if (oldsiz-newsiz>0) then + star('Space saved : '+cstrl(oldsiz-newsiz)+' bytes') + else + star('Space wasted : '+cstrl(newsiz-oldsiz)+' bytes'); + end; + end else begin + sysoplog('Unable to convert "'+sqoutsp(fn)+'"'); + star('Unable to convert "'+sqoutsp(fn)+'"'); + end; + end; + findnext(dirinfo); + wkey(abort,next); + end; +{ if (abort) then sprint('@M'+#3#7+'Conversion aborted.');} + end else begin + ok1:=pynq('Search all directories? '); + nl; + if (ok1) then begin + i:=0; abort:=FALSE; next:=FALSE; + while (not abort) and (i<=maxulb) and (not hangup) do begin + if (fbaseac(i)) then + cvtfiles(i,fn,bb,c_files,c_oldsiz,c_newsiz,abort,next); + inc(i); + wkey(abort,next); + if (next) then abort:=FALSE; + end; + end else + cvtfiles(fileboard,fn,bb,c_files,c_oldsiz,c_newsiz, + abort,next); + reset(ulff); + end; + sysoplog('Conversion process ended at '+date+' '+time+'.'); + nl; + nl; + star('Total archives converted : '+cstr(c_files)); + star('Old total space took up : '+cstrl(c_oldsiz)+' bytes'); + star('New total space taken up : '+cstrl(c_newsiz)+' bytes'); + if (c_oldsiz-c_newsiz>0) then + star('Space saved : '+cstrl(c_oldsiz-c_newsiz)+' bytes') + else + star('Space wasted : '+cstrl(c_newsiz-c_oldsiz)+' bytes'); + sysoplog('Converted '+cstr(c_files)+' archives; old size='+ + cstrl(c_oldsiz)+' bytes, new size='+cstrl(c_newsiz)+' bytes'); + end; + end; + end; + 'M':begin + nl; + print('Comment field update -'); + nl; + print('Filespec:'); + prt(':'); mpl(78); input(fn,78); + if (fn<>'') then begin + nl; + abort:=FALSE; next:=FALSE; + if (isul(fn)) then begin + prt('Comment type to use? (1-3,0=None) [1] : '); + ini(bb); + if (badini) then bb:=1; + if (bb<0) or (bb>3) then bb:=1; + fsplit(fn,dstr,nstr,estr); s:=dstr; + findfirst(fn,AnyFile-Directory-VolumeID,dirinfo); + abort:=FALSE; next:=FALSE; + while (doserror=0) and (not abort) and (not hangup) do begin + fn:=fexpand(sqoutsp(dstr+dirinfo.name)); + atype:=arctype(fn); + if (atype<>0) then begin + star('Commenting "'+fn+'"'); + ok:=TRUE; + arccomment(ok,atype,bb,fn); + end; + findnext(dirinfo); + wkey(abort,next); + end; +{ if (abort) then sprint('@M'+#3#7+'Comment update aborted.');} + end else begin + ok1:=pynq('Search all directories? '); + nl; + if (ok1) then begin + i:=0; abort:=FALSE; next:=FALSE; + while (not abort) and (i<=maxulb) and (not hangup) do begin + if (fbaseac(i)) then cmtfiles(i,fn,abort,next); + inc(i); + wkey(abort,next); + if (next) then abort:=FALSE; + end; + end else + cmtfiles(fileboard,fn,abort,next); + reset(ulff); + end; + end; + end; + 'T':begin + nl; + print('File integrity testing -'); + nl; + print('Filespec:'); + prt(':'); mpl(78); input(fn,78); + if (fn<>'') then begin + nl; + delbad:=pynq('Delete files that don''t pass the test? '); + nl; + abort:=FALSE; next:=FALSE; + if (isul(fn)) then begin + fsplit(fn,dstr,nstr,estr); s:=dstr; + findfirst(fn,AnyFile-Directory-VolumeID,dirinfo); + abort:=FALSE; next:=FALSE; + while (doserror=0) and (not abort) and (not hangup) do begin + fn:=fexpand(sqoutsp(dstr+dirinfo.name)); + atype:=arctype(fn); + if (atype<>0) then begin + star('Testing "'+fn+'"'); + ok:=TRUE; + arcintegritytest(ok,atype,fn); + if (not ok) then begin + star('File "'+fn+'" didn''t pass integrity test.'); + if (delbad) then begin + assign(fi,fn); + {$I-} erase(fi); {$I+} + if (ioresult<>0) then star('Error erasing "'+fn+'"!'); + end; + end; + end; + findnext(dirinfo); + wkey(abort,next); + end; +{ if (abort) then sprint('@M'+#3#7+'Integrity testing aborted.');} + end else begin + ok1:=pynq('Search all directories? '); + nl; + if (ok1) then begin + i:=0; abort:=FALSE; next:=FALSE; + while (not abort) and (i<=maxulb) and (not hangup) do begin + if (fbaseac(i)) then testfiles(i,fn,delbad,abort,next); + inc(i); + wkey(abort,next); + if (next) then abort:=FALSE; + end; + end else + testfiles(fileboard,fn,delbad,abort,next); + reset(ulff); + end; + end; + end; + 'X':begin {* extract *} + end; + end; + close(ulff); + thisuser.flistopt:=savflistopt; + if (savpause) then thisuser.ac:=thisuser.ac+[pause]; +end; + +end. diff --git a/archive3.pas b/archive3.pas new file mode 100644 index 0000000..ea3e810 --- /dev/null +++ b/archive3.pas @@ -0,0 +1,196 @@ +{$A+,B+,D-,E+,F+,I+,L-,N-,O+,R-,S+,V-} +unit archive3; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + archive1, + common, + execbat, + file0, file11; + +procedure rezipstuff; + +implementation + +var rezipcmd:string; + +procedure cvtfiles(b:integer; fn:astr; var c_files,c_oldsiz,c_newsiz:longint; + var abort,next:boolean); +var fi:file of byte; + f:ulfrec; + s,ps,ns,es:astr; + oldsiz,newsiz:longint; + oldboard,pl,rn,atype:integer; + ok:boolean; +begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + recno(fn,pl,rn); { loads in memuboard } + abort:=FALSE; next:=FALSE; + while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + fn:=memuboard.dlpath+f.filename; + atype:=arctype(fn); + if (atype<>0) then begin + pbn(abort,next); nl; + star('Converting "'+sqoutsp(fn)+'"'); + ok:=FALSE; + if (not exist(fn)) then + star('File "'+sqoutsp(fn)+'" doesn''t exist.') + else begin + if (rezipcmd<>'') then begin + assign(fi,sqoutsp(fn)); + {$I-} reset(fi); {$I+} + if (ioresult=0) then begin + oldsiz:=trunc(filesize(fi)); + close(fi); + end; + shel1; + execbatch(ok,TRUE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'1\', + rezipcmd+' '+sqoutsp(fn),-1); + shel2; + assign(fi,sqoutsp(fn)); + {$I-} reset(fi); {$I+} + if (ioresult=0) then begin + newsiz:=trunc(filesize(fi)); + f.blocks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + seek(ulff,rn); write(ulff,f); + end; + end else begin + ok:=TRUE; + s:=fn; + conva(ok,atype,atype,systat.temppath+'1\',sqoutsp(fn),sqoutsp(s)); + if (ok) then begin + fsplit(fn,ps,ns,es); fn:=ps+ns+'.#$%'; + assign(fi,sqoutsp(fn)); + {$I-} reset(fi); {$I+} + ok:=(ioresult=0); + if (ok) then begin + oldsiz:=trunc(filesize(fi)); + close(fi); + end else + star('Unable to access "'+sqoutsp(fn)+'"'); + if (ok) then + if (not exist(sqoutsp(s))) then begin + star('Unable to access "'+sqoutsp(s)+'"'); + sysoplog('Unable to access "'+sqoutsp(s)+'"'); + ok:=FALSE; + end; + end; + if (ok) then begin + f.filename:=align(stripname(sqoutsp(s))); + seek(ulff,rn); write(ulff,f); + + fsplit(fn,ps,ns,es); fn:=ps+ns+'.#$%'; + assign(fi,fn); {$I-} erase(fi); {$I+} + + if (ioresult<>0) then begin + star('Unable to erase "'+sqoutsp(fn)+'"'); + sysoplog('Unable to erase "'+sqoutsp(fn)+'"'); + end; + + assign(fi,sqoutsp(s)); + {$I-} reset(fi); {$I+} + ok:=(ioresult=0); + if (not ok) then begin + star('Unable to access "'+sqoutsp(s)+'"'); + sysoplog('Unable to access "'+sqoutsp(s)+'"'); + end else begin + newsiz:=trunc(filesize(fi)); + f.blocks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + seek(ulff,rn); write(ulff,f); + arccomment(ok,atype,memuboard.cmttype,sqoutsp(s)); + end; + end else begin + sysoplog('Unable to convert "'+sqoutsp(fn)+'"'); + star('Unable to convert "'+sqoutsp(fn)+'"'); + end; + end; + if (ok) then begin + inc(c_oldsiz,oldsiz); + inc(c_newsiz,newsiz); + inc(c_files); + star('Old total space took up : '+cstrl(oldsiz)+' bytes'); + star('New total space taken up : '+cstrl(newsiz)+' bytes'); + if (oldsiz-newsiz>0) then + star('Space saved : '+cstrl(oldsiz-newsiz)+' bytes') + else + star('Space wasted : '+cstrl(newsiz-oldsiz)+' bytes'); + end; + end; + end; + nrecno(fn,pl,rn); + wkey(abort,next); + end; + close(ulff); + end; + fileboard:=oldboard; +end; + +procedure rezipstuff; +var fn:astr; + c_files,c_oldsiz,c_newsiz:longint; + i:integer; + abort,next,ok1:boolean; +begin + nl; + print('Re-compress archives -'); + nl; + print('Filespec:'); + prt(':'); mpl(78); input(fn,78); + c_files:=0; c_oldsiz:=0; c_newsiz:=0; + if (fn<>'') then begin + nl; + sprint(#3#7+'Do you wish to use a REZIP external utility?'); + if pynq('(such as REZIP.EXE) ? (Y/N) : ') then begin + nl; + prt('Enter commandline (example: "REZIP") : '); + input(rezipcmd,100); + if (rezipcmd='') then exit; + end else + rezipcmd:=''; + nl; + abort:=FALSE; next:=FALSE; + ok1:=pynq('Search all directories? '); + nl; + sysoplog('Conversion process began at '+date+' '+time+'.'); + print('Conversion process began at '+date+' '+time+'.'); + nl; + if (ok1) then begin + i:=0; abort:=FALSE; next:=FALSE; + while ((not abort) and (i<=maxulb) and (not hangup)) do begin + if (fbaseac(i)) then + cvtfiles(i,fn,c_files,c_oldsiz,c_newsiz,abort,next); + inc(i); + wkey(abort,next); + if (next) then abort:=FALSE; + end; + end else + cvtfiles(fileboard,fn,c_files,c_oldsiz,c_newsiz,abort,next); + end; + nl; + sysoplog('Conversion process ended at '+date+' '+time+'.'); + print('Conversion process ended at '+date+' '+time+'.'); + nl; + nl; + star('Total archives converted : '+cstr(c_files)); + star('Old total space took up : '+cstrl(c_oldsiz)+' bytes'); + star('New total space taken up : '+cstrl(c_newsiz)+' bytes'); + if (c_oldsiz-c_newsiz>0) then + star('Space saved : '+cstrl(c_oldsiz-c_newsiz)+' bytes') + else + star('Space wasted : '+cstrl(c_newsiz-c_oldsiz)+' bytes'); + sysoplog('Converted '+cstr(c_files)+' archives; old size='+ + cstrl(c_oldsiz)+' bytes, new size='+cstrl(c_newsiz)+' bytes'); +end; + +end. diff --git a/ascii.inc b/ascii.inc new file mode 100644 index 0000000..75ee9c3 --- /dev/null +++ b/ascii.inc @@ -0,0 +1,26 @@ +(*----------------------------------------------------------------------*) +(* ASCII character set definitions *) +(*----------------------------------------------------------------------*) + +const + NUL = 0; (* NULL Character *) + ETX = 3; (* ETX = ^C *) + ENQ = 5; (* ENQ Character *) + ACK = 6; + BELL = 7; (* BELL Character *) + BS = 8; (* Backspace Char *) + HT = 9; (* Horizontal Tab *) + LF = 10; (* Line Feed *) + VT = 11; (* Vertical Tab *) + FF = 12; (* Form Feed *) + CR = 13; (* Carriage Return *) + SO = 14; (* Start grahics *) + SI = 15; (* End graphics *) + XON = 17; (* XON Character *) + XOFF = 19; (* XOFF Character *) + CAN = 24; + SUB = 26; (* EOF Character *) + ESC = 27; (* Escape *) + SP = 32; (* Space *) + DEL = 127; (* DEL Character *) + diff --git a/asyint.map b/asyint.map new file mode 100644 index 0000000..56bbb82 --- /dev/null +++ b/asyint.map @@ -0,0 +1,38 @@ + + Start Stop Length Name Class + + 00000H 001AEH 001AFH CODE + 001B0H 001B0H 00000H DATA + +Undefined symbol 'ASYNC_UART_IIR' in module ASYINT.ASM +Undefined symbol 'ASYNC_BASE' in module ASYINT.ASM +Undefined symbol 'ASYNC_DO_XONXOFF' in module ASYINT.ASM +Undefined symbol 'ASYNC_XOFF_RECEIVED' in module ASYINT.ASM +Undefined symbol 'ASYNC_XOFF_REC_DISPLAY' in module ASYINT.ASM +Undefined symbol 'ASYNC_XON_REC_DISPLAY' in module ASYINT.ASM +Undefined symbol 'ASYNC_LINE_STATUS' in module ASYINT.ASM +Undefined symbol 'ASYNC_BUFFER_HEAD' in module ASYINT.ASM +Undefined symbol 'ASYNC_BUFFER_PTR' in module ASYINT.ASM +Undefined symbol 'ASYNC_BUFFER_USED' in module ASYINT.ASM +Undefined symbol 'ASYNC_MAXBUFFERUSED' in module ASYINT.ASM +Undefined symbol 'ASYNC_BUFFER_SIZE' in module ASYINT.ASM +Undefined symbol 'ASYNC_BUFFER_TAIL' in module ASYINT.ASM +Undefined symbol 'ASYNC_BUFFER_HIGH' in module ASYINT.ASM +Undefined symbol 'ASYNC_XOFF_SENT' in module ASYINT.ASM +Undefined symbol 'ASYNC_BUFFER_HIGH_2' in module ASYINT.ASM +Undefined symbol 'ASYNC_SEND_XOFF' in module ASYINT.ASM +Undefined symbol 'ASYNC_DO_DSR' in module ASYINT.ASM +Undefined symbol 'ASYNC_UART_MSR' in module ASYINT.ASM +Undefined symbol 'ASYNC_DO_CTS' in module ASYINT.ASM +Undefined symbol 'ASYNC_OBUFFER_TAIL' in module ASYINT.ASM +Undefined symbol 'ASYNC_OBUFFER_HEAD' in module ASYINT.ASM +Undefined symbol 'ASYNC_UART_IER' in module ASYINT.ASM +Undefined symbol 'ASYNC_MODEM_STATUS' in module ASYINT.ASM +Undefined symbol 'ASYNC_OBUFFER_PTR' in module ASYINT.ASM +Undefined symbol 'ASYNC_OBUFFER_USED' in module ASYINT.ASM +Undefined symbol 'ASYNC_OBUFFER_SIZE' in module ASYINT.ASM +Undefined symbol 'ASYNC_UART_LSR' in module ASYINT.ASM +Undefined symbol 'ASYNC_LINE_ERROR_FLAGS' in module ASYINT.ASM +Program entry point at 0000:0000 +Warning: no stack + diff --git a/bb.pas b/bb.pas new file mode 100644 index 0000000..d82ce83 --- /dev/null +++ b/bb.pas @@ -0,0 +1,389 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +{$M 32150,0,0} { Declared here suffices for all Units as well! } + +program BatchBackup; + +uses + crt,dos, + myio; + +{$I func.pas} + +type + lbrec=record + drv:char; + lb:datetime; + nacc:integer; + end; + +const + lastspec='c:\lastbak.txt'; + cline='tape SBK @D:\/S-\TRAP*.MSG/S-\BBS.OVR/S-\BBS.EXE/S/A/C/C+/-O/R@T/LBAK@D@N'; + lodrv:char='C'; + hidrv:char='E'; + go:boolean=FALSE; + abort:boolean=FALSE; + firstq:boolean=TRUE; + +var + lbdrv:array['C'..'G'] of lbrec; + tagged:array['C'..'G'] of boolean; + wind,winds:windowrec; + y,oy:char; + sx,sy:integer; + lbf:file of lbrec; + +{rcg11172000 had to change this to get it compiling under Free Pascal...} +{function substall(src,old,new:string):string;} +function substall(src,old,_new:string):string; +var p:integer; +begin + p:=1; + while p>0 do begin + p:=pos(old,src); + if p>0 then begin + insert(_new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substall:=src; +end; + +function sdat(dt:datetime):string; + + function tch(i:integer):string; + var s:string; + begin + str(i,s); + if i<10 then s:='0'+s; + if i<0 then s:='00'; + tch:=s; + end; + +begin + with dt do + sdat:=tch(month)+'/'+tch(day)+'/'+tch(year-1900)+' '+tch(hour)+':'+tch(min)+':'+tch(sec); +end; + +procedure unsdat(s:string; var dt:datetime); +var x:integer; +begin + with dt do begin + val(copy(s,7,2),year,x); inc(year,1900); + val(copy(s,1,2),month,x); + val(copy(s,4,2),day,x); + val(copy(s,10,2),hour,x); + val(copy(s,13,2),min,x); + val(copy(s,16,2),sec,x); + end; +end; + +procedure datnow(var dt:datetime); +var r:registers; +begin + with dt, r do begin + ax:=$2a00; msdos(dos.registers(r)); + year:=cx; + month:=dx shr 8; + day:=dx mod 256; + ax:=$2c00; msdos(dos.registers(r)); {intr($21,dos.registers(r));} + hour:=cx shr 8; + min:=cx mod 256; + sec:=dx shr 8; + end; +end; + +function dtchk(s:string):boolean; +begin + dtchk:=FALSE; + if (s[1] in ['0'..'9']) and (s[2] in ['0'..'9']) and + (s[4] in ['0'..'9']) and (s[5] in ['0'..'9']) and + (s[7] in ['0'..'9']) and (s[8] in ['0'..'9']) then dtchk:=TRUE; +end; + +function gooddate(s:string):boolean; +begin + gooddate:=FALSE; + if (s[3] in ['-','/']) and (s[6] in ['-','/']) and (length(s)=8) then + if dtchk(s) then gooddate:=TRUE; +end; + +procedure inlast; +var c:char; + dt:datetime; +begin + datnow(dt); + assign(lbf,lastspec); + {$I-} reset(lbf); {$I+} + if ioresult=0 then + for c:=lodrv to hidrv do + read(lbf,lbdrv[c]) + else begin + rewrite(lbf); + for c:=lodrv to hidrv do begin + with lbdrv[c] do begin + drv:=c; + lb:=dt; + nacc:=0; + end; + write(lbf,lbdrv[c]); + end; + end; + close(lbf); +end; + +procedure tagall; +var c:char; +begin + for c:=lodrv to hidrv do tagged[c]:=TRUE; +end; + +procedure setscreen; +begin + sx:=wherex; sy:=wherey; + savescreen(winds,1,1,80,25); + setwindow(wind,10,3,53,ord(hidrv)-ord(lodrv)+10,9,1,1); + window(12,4,52,ord(hidrv)-ord(lodrv)+9); + clrscr; +end; + +procedure init; +begin + inlast; + tagall; + setscreen; +end; + +procedure closeup; +begin + removewindow(winds); + gotoxy(sx,sy); +end; + +procedure sc(s:string); +const bcol:boolean=FALSE; + fcol:boolean=FALSE; +var i:integer; +begin + for i:=1 to length(s) do + if not fcol then + if not bcol then + case s[i] of + #3:fcol:=TRUE; + #4:bcol:=TRUE; + else + write(s[i]); + end + else begin + bcol:=FALSE; + textbackground(ord(s[i])); + end + else begin + fcol:=FALSE; + textcolor(ord(s[i])); + end; +end; + +procedure scln(s:string); +begin + sc(s); + writeln; +end; + +procedure showstuff; +var c:char; + s:string; +begin + gotoxy(1,3); + for c:=lodrv to hidrv do begin + if tagged[c] then sc(#3#15+'+') else sc(#3#9+'-'); + sc(#3#11+' Drive '+c+':'+#3#9+' Since '+#3#14+sdat(lbdrv[c].lb)); + str(lbdrv[c].nacc,s); + scln(#3#9+' (#'+s+')'); + end; + writeln; + scln(#3#11+' OK'); + sc(#3#11+' Abort'); +end; + +procedure lin(i:integer); + + procedure dd(y:char); + begin + if y<=hidrv then sc('Drive '+y+':') else + if y=chr(ord(hidrv)+2) then sc('OK') else + if y=chr(ord(hidrv)+3) then sc('Abort'); + end; + +begin + case i of + 0:begin + gotoxy(3,ord(oy)-64); + sc(#4#1+#3#11); + dd(oy); + end; + 1:begin + gotoxy(3,ord(y)-64); + sc(#4#3+#3#0); + dd(y); + end; + end; +end; + +procedure glin; +begin + lin(0); lin(1); + oy:=y; +end; + +procedure tell(s:string); +var i:integer; +begin + CursorOff; + i:=40-(length(s) div 2)-3; + setwindow(wind,i,10,i+length(s)+5,14,9,1,1); + gotoxy(3,2); textcolor(15); writeln(s); +end; + + +{rcg11172000 added by me.} +procedure CursorOn; +begin + writeln('STUB: bb.pas; CursorOn()...'); +end; +{rcg11172000 adds end.} + + +procedure makesound; +var i,j,k:integer; +begin + i:=100; + repeat + sound(i); + delay(i div 100); + j:=100; + repeat + sound(j); + delay(j div 100); + k:=100; + repeat + sound(k); + delay(k div 30); + inc(k,j); + until (k>=2000) or (keypressed); + inc(j,i); + until (j>=500) or (keypressed); + inc(i,k); + until (i>=1000) or (keypressed); + nosound; +end; + +var + c:char; + s,s1,s2:string; + changed:boolean; + dt:datetime; + bf:text; + i:integer; + +begin + init; + + infield_out_fgrd:=14; infield_out_bkgd:=1; + infield_inp_fgrd:=0; infield_inp_bkgd:=7; + + scln(#3#15+'Backup new files'); + writeln; + showstuff; + y:=chr(ord(hidrv)+2); oy:=y; glin; + + repeat + case readkey of + #0 :case ord(readkey) of + ARROW_UP :if y=chr(ord(hidrv)+2) then y:=pred(pred(y)) else y:=pred(y); + ARROW_DOWN :if y=hidrv then y:=succ(succ(y)) else y:=succ(y); + ARROW_LEFT, + ARROW_RIGHT:begin + changed:=FALSE; + s:=sdat(lbdrv[y].lb); + s1:=copy(s,1,8); s2:=copy(s,10,8); + infield1(18,ord(y)-64,s1,8); + if not gooddate(s1) then s1:=copy(s,1,8); + if s1<>copy(s,1,8) then changed:=TRUE; + gotoxy(18,ord(y)-64); write(s1); + if changed then unsdat(s1+' '+s2,lbdrv[y].lb); + changed:=FALSE; + end; + end; + #13:if y>hidrv then go:=TRUE + else begin + tagged[y]:=not tagged[y]; + lin(0); showstuff; + glin; + end; + #27:begin + y:=chr(ord(hidrv)+3); + go:=TRUE; + end; + end; + if y>chr(ord(hidrv)+3) then y:=lodrv; + if yoy then glin; + until (go); + lin(0); + + abort:=(y=chr(ord(hidrv)+3)); + + removewindow(wind); + + if not abort then begin + for c:=lodrv to hidrv do + if tagged[c] then begin + inc(lbdrv[c].nacc); + + assign(bf,'tempbat.bat'); + rewrite(bf); +{ writeln(bf,'@echo off');} + writeln(bf,'cls'); + s1:=sdat(lbdrv[c].lb); s1:=copy(s1,1,8); str(lbdrv[c].nacc,s2); + s:=substall(cline,'@D',c); + s:=substall(s,'@N',s2); + s:=substall(s,'@T',s1); + writeln(bf,s); + close(bf); + + datnow(dt); + lbdrv[c].lb:=dt; + + removewindow(winds); + tell('Insert tape for drive '+c+': ...'); + if not firstq then begin + repeat + makesound; + i:=0; + repeat + inc(i); + until (i=0) or (keypressed); + until keypressed; + end; + + firstq:=FALSE; + y:=readkey; + removewindow(wind); + CursorOn; + + rewrite(lbf); + for c:=lodrv to hidrv do + with lbdrv[c] do + write(lbf,lbdrv[c]); + close(lbf); + + exec(getenv('COMSPEC'),'/c tempbat.bat'); + erase(bf); + abort:=TRUE; + makesound; + end; + end; + + closeup; +end. diff --git a/bbs.pas b/bbs.pas new file mode 100644 index 0000000..0945a3c --- /dev/null +++ b/bbs.pas @@ -0,0 +1,332 @@ +{***************************************************************************** + * Project Coyote * + * =================== * + * * + * Modification History * + * ==================== * + * 11/19/92 - 0.14 - Robert Merritt * + * * + * * + * NOTE: Project Coyote originated from TeleGard 2.5i which was originally * + * written by Eric Oman, and Martin Pollard. * + * * + *****************************************************************************} +{$A+,B+,D-,E+,F+,I+,L-,N-,O+,R-,S+,V-} +{$M 60000,0,45000} { Memory Allocation Sizes } + +Program BBS; +Uses + + {rcg11172000 no overlay under Linux.} + {Overlay,} + + Crt, Dos, InitP, Sysop1, Sysop2, Sysop3, + Sysop4, Sysop5, Sysop6, Sysop7, Sysop8, Sysop9, Sysop10, + Sysop11, Mail0, Mail1, Mail2, Mail3, Mail4, Mail5, + Mail6, Mail9, File0, File1, File2, File3, File4, + File5, File6, File7, File8, File9, File10, File11, + File12, File13, File14, Archive1, Archive2, Archive3, Misc1, + Misc2, Misc3, Misc4, MiscX, CUser, Doors, Menus2, + Menus3, Menus4, MyIO, Logon1, Logon2, NewUsers, WfcMenu, + Menus, FvType, TimeJunk, TmpCom, MsgPack, Common, Common1, + Common2, Common3, ExecSwap; {* MiniTerm, Window2, NewCom *} + +{$O MsgPack } {$O Common1 } {$O Common2 } {$O Common3 } {$O InitP } +{$O WfcMenu } {$O FvType } {$O TimeJunk } {$O Sysop1 } {$O Sysop2 } +{$O Sysop21 } {$O Sysop2a } {$O Sysop2b } {$O Sysop2c } {$O Sysop2d } +{$O Sysop2e } {$O Sysop2f } {$O Sysop2fa } {$O Sysop2g } {$O Sysop2h } +{$O Sysop2i } {$O Sysop2s } {$O Sysop2z } {$O Sysop3 } {$O Sysop4 } +{$O Sysop5 } {$O Sysop6 } {$O Sysop7 } {$O Sysop7m } {$O Sysop8 } +{$O Sysop9 } {$O Sysop10 } {$O Sysop11 } {$O Mail0 } {$O Mail1 } +{$O Mail2 } {$O Mail3 } {$O Mail4 } {$O Mail5 } {$O Mail6 } +{$O Mail9 } {$O File0 } {$O File1 } {$O File2 } {$O File3 } +{$O File4 } {$O File5 } {$O File6 } {$O File7 } {$O File8 } +{$O File9 } {$O File10 } {$O File11 } {$O File12 } {$O File13 } +{$O File14 } {$O Archive1 } {$O Archive2 } {$O Archive3 } {$O Logon1 } +{$O Logon2 } {$O NewUsers } {$O Misc1 } {$O Misc2 } {$O Misc3 } +{$O Misc4 } {$O MiscX } {$O CUser } {$O Doors } {$O ExecBat } +{$O MyIO } {$O Menus2 } {$O Menus3 } {$O Menus4 } + +Const + OvrMaxSize = 60000; + BBSMaxHeapSpace = 40000; + +{$I LcBbs.Pas} + +Var + ExitSave : Pointer; + ExecFirst : Boolean; + NewMenuCmd: String; + +Procedure ErrorHandle; +{***************************************************************************** + * Note: if error occurs IN THIS PROCEDURE, * + * it is NOT executed again! That way an infinite loop is *avoided*.... * + *****************************************************************************} +Var + T:Text; + F:File; + S:String[80]; + VidSeg:Word; + X,Y:Integer; + C:Char; +Begin + ExitProc:=ExitSave; + If (ErrorAddr<>Nil) then + Begin + chdir(start_dir); + if (textrec(sysopf).mode=fmoutput) then + begin + writeln(sysopf,#3#8+'*>>'+#3#7+' Runtime error '+cstr(exitcode)+ + ' at '+date+' '+time+#3#8+' <<*'+#3#5+ + ' (Check ERR.LOG in main BBS dir)'); + flush(sysopf); close(sysopf); + end; + if (textrec(trapfile).mode=fmoutput) then + begin + writeln(trapfile,'*>> Runtime error '+cstr(exitcode)+' at '+date+' '+ + time+' <<*'); + flush(trapfile); close(trapfile); + end; + + assign(t,'err.log'); + {$I-} append(t); {$I+} + if (ioresult<>0) then + begin + rewrite(t); + append(t); + writeln(t,'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ'); + writeln(t,'Critical Error Log file - Contains screen images at instant of Error.'); + writeln(t); + end; + writeln(t); + if (serialnumber<>0) then + s:=' ('+cstr(serialnumber)+vercs+')' + else + s:=''; + writeln(t,'¯>¯ RT #'+cstr(exitcode)+' at '+date+' '+time+' BBS-Ver: '+ver+s); + if (useron) then begin + if (spd<>'KB') then s:='at '+spd+' baud' else s:='Locally'; + writeln(t,'¯>¯ User "'+allcaps(thisuser.name)+' #'+cstr(usernum)+ + '" was on '+s); + end; + writeln(t,'®®®®®®®®®®®®®®®®®®®®®®®®®®®® <®- Screen Image: -¯> ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯'); + + {rcg11172000 Not under Linux...} + { + if (mem[$0000:$0449]=7) then vidseg:=$B000 else vidseg:=$B800; + for y:=1 to 25 do + begin + s:=''; + for x:=1 to 80 do + begin + c:=chr(mem[vidseg:(160*(y-1)+2*(x-1))]); + if (c=#0) then c:=#32; + if ((x=wherex) and (y=wherey)) then c:=#178; + if ((x<>80) or ((x=80) and (c<>#32))) then s:=s+c; + end; + writeln(t,s); + end; + } + + + writeln('STUB: bbs.pas; ErrorHandler()...'); + writeln(t, ' (No screen dump. Sorry. --ryan.)'); + + + writeln(t,'®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®*¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯'); + close(t); + + assign(f,'critical.err'); rewrite(f); close(f); setfattr(f,dos.hidden); + + sprint(#3#8+'*>>'+#3#7+' System error occured at '+date+' '+time+#3#8+' <<*'); + term_ready(TRUE); remove_port; {removeint(modemr.comport);} + writeln('*>> System error '+cstr(exitcode)+' at '+date+' '+time+' <<*'); + + if (exiterrors<>-1) then halt(exiterrors) else halt(254); + {* CRITICAL ERROR ERRORLEVEL *} + end; +end; + +Procedure MenuExec; +Var + Dt : LDateTimeRec; + Cmd,s : String; + I : Integer; + Aa,Abort,Next,Done:Boolean; +Begin + If (ExecFirst) then + Begin + ExecFirst:=FALSE; + Cmd:=NewMenuCmd; + NewMenuCmd:=''; + End Else MainMenuHandle(Cmd); + + if ((copy(cmd,1,2)='\\') and (thisuser.sl=255)) then begin + domenucommand(done,copy(cmd,3,length(cmd)-2),newmenucmd); + if (newmenucmd<>'') then cmd:=newmenucmd else cmd:=''; + end; + + If (Cmd='|') then + Begin + nl; sprint(#3#3+verline(1)); sprint(#3#3+verline(2)); nl; + pdt2dt(sitedatetime,dt); + sprint(#3#3+'Release date: unreleased '); + lastcommandgood:=TRUE; + end else + if ((cmd='=') and (cso)) then showmenucmds + else + if (cmd<>'') then + begin + newmenucmd:=''; + repeat domenuexec(cmd,newmenucmd) until (newmenucmd=''); + end; +end; + +Var + OvrPath,VerType : String; + I,RCode : Integer; + NeedToHangup : Boolean; + SyStatF : File of systatrec; +Begin + exitsave:=exitproc; + exitproc:=@errorhandle; + + MaxHeapSpace:=BBSMaxHeapSpace; + checksnow:=TRUE; directvideo:=FALSE; + + useron:=FALSE; usernum:=0; + getdir(0,start_dir); + + assign(systatf,'status.dat'); + {$I-} reset(systatf); {$I+} + if (ioresult<>0) then + begin + writeln; + writeln('Unable to find STATUS.DAT data file. This file is absolutely'); + writeln('*REQUIRED* to even load the BBS. If you cannot find your'); + writeln('STATUS.DAT data file, re-create one using the INIT package.'); + if (exiterrors<>-1) then halt(exiterrors) else halt(254); + end else begin + {$I-} read(systatf,systat); {$I+} + close(systatf); + end; + + {rcg11172000 No overlay on Linux.} + { + ovrinit('bbs.OVR'); + ovrpath:=fsearch('bbs.OVR',getenv('PATH')); + if (ovrresult<>ovrok) then + begin + clrscr; writeln('Critical error: Overlay manager error.'); halt(1); + end; + if (systat.useems) then + begin + ovrinitems; if (ovrresult=ovrok) then overlayinems:=TRUE; + end; + ovrsetbuf(ovrmaxsize); ovrsetretry(ovrmaxsize div 2); + } + + initexecswap2:=initexecswap; + execwithswap2:=execwithswap; + shutdownexecswap2:=shutdownexecswap; + + findvertypeout(ovrpath,vercs,vertype,vertypes,serialnumber,licenseinfo,sitedatetime); + ver:=ver+' '+vertype; + + init; + + if (packbasesonly) then + begin + wfcmdefine; doshowpackbases; thisuser.ac:=thisuser.ac-[pause]; nl; + sprint(#3#5+'Message bases have been packed.'); + cursoron(TRUE); halt(0); + end; + mailread:=FALSE; smread:=FALSE; + + needtohangup:=wascriterr; { hang up if critical error last call! } + + repeat + write_msg:=FALSE; + sysopon:=not systat.localsec; + wantout:=not systat.localscreensec; + checksnow:=systat.cgasnow; + + wfcmenus(needtohangup); + needtohangup:=FALSE; + + useron:=FALSE; usernum:=0; + if (not doneday) then + begin + if (getuser) then newuser; + if (not hangup) then + begin + macok:=TRUE; + if (not hangup) then logon; + if (not hangup) then + begin + with thisuser do + begin + newdate:=laston; + if (not mbaseac(lastmsg)) then lastmsg:=1; + if (not fbaseac(lastfil)) then lastfil:=1; + board:=lastmsg; fileboard:=lastfil; + end; + batchtime:=0.0; numbatchfiles:=0; numubatchfiles:=0; hiubatchv:=0; + newcomptables; + + menustackptr:=0; for i:=1 to 8 do menustack[i]:=''; + + last_menu:=systat.allstartmenu+'.MNU'; + + if (not exist(systat.menupath+last_menu)) then + begin + sysoplog('"'+systat.menupath+last_menu+'" is MISSING. Loaded "MAIN.MNU" instead.'); + last_menu:='main.mnu'; + end; + curmenu:=systat.menupath+last_menu; readin; + + if (novice in thisuser.ac) then chelplevel:=2 else chelplevel:=1; + end; + + newmenucmd:=''; i:=1; + while ((i<=noc) and (newmenucmd='')) do + begin + if (cmdr[i].ckeys='FIRSTCMD') then + if (aacs(cmdr[i].acs)) then newmenucmd:='FIRSTCMD'; + inc(i); + end; + execfirst:=(newmenucmd='FIRSTCMD'); + while (not hangup) do menuexec; {*** main BBS loop ***} + end; + + if (quitafterdone) then + begin + elevel:=exitnormal; hangup:=TRUE; doneday:=TRUE; needtohangup:=TRUE; + end; + logoff; + if (not doneday) then sl1(#3#3+'Logoff '+#3#5+'['+dat+']'); + + if (textrec(sysopf1).mode=fmoutput) then + begin + {$I-} close(sysopf1); {$I+} + if (ioresult<>0) then writeln('Errors closing SLOGxxxx.LOG'); + end; + + if ((com_carrier) and (not doneday)) then + if (spd<>'KB') then needtohangup:=TRUE; + if (enddayf) then endday; + enddayf:=FALSE; + end; + until (doneday); + + if (needtohangup) then hangupphone; + reset(sysopf); close(sysopf); + term_ready(TRUE); remove_port; {removeint(modemr.comport);} + + if (exist('bbsdone.bat')) then shelldos(FALSE,'bbsdone.bat',rcode); + + textcolor(7); clrscr; textcolor(14); + WriteLn('[> Exited with ErrorLevel ',elevel,' at '+date+' '+time); + halt(elevel); +end. diff --git a/bbs.~pa b/bbs.~pa new file mode 100644 index 0000000..7e37de6 --- /dev/null +++ b/bbs.~pa @@ -0,0 +1,350 @@ +{***************************************************************************** + * T E L E G A R D - X * + * =================== * + * * + * Modification History * + * ==================== * + * 08/20/91 - 0.90 - Rls - Original Version. * + * Sad - Original Version. * + * * + * NOTE: TeleGard-X originated from TeleGard 2.5i which was originally * + * written by Eric Oman, and Martin Pollard. * + * * + *****************************************************************************} +{$A+,B+,D-,E+,F+,I+,L-,N-,O+,R-,S+,V-} +{$M 60000,0,45000} { Memory Allocation Sizes } + +Program TeleGard-X; +Uses + Crt, Dos, OverLay, InitP, Sysop1, Sysop2, Sysop3, + Sysop4, Sysop5, Sysop6, Sysop7, Sysop8, Sysop9, Sysop10, + Sysop11, Mail0, Mail1, Mail2, Mail3, Mail4, Mail5, + Mail6, Mail9, File0, File1, File2, File3, File4, + File5, File6, File7, File8, File9, File10, File11, + File12, File13, File14, Archive1, Archive2, Archive3, Misc1, + Misc2, Misc3, Misc4, MiscX, CUser, Doors, Menus2, + Menus3, Menus4, MyIO, Logon1, Logon2, NewUsers, WfcMenu, + Menus, FvType, TimeJunk, TmpCom, MsgPack, Common, Common1, + Common2, Common3, ExecSwap; {* MiniTerm, Window2, NewCom *} + +{$O MsgPack } {$O Common1 } {$O Common2 } {$O Common3 } {$O InitP } +{$O WfcMenu } {$O FvType } {$O TimeJunk } {$O Sysop1 } {$O Sysop2 } +{$O Sysop21 } {$O Sysop2a } {$O Sysop2b } {$O Sysop2c } {$O Sysop2d } +{$O Sysop2e } {$O Sysop2f } {$O Sysop2fa } {$O Sysop2g } {$O Sysop2h } +{$O Sysop2i } {$O Sysop2s } {$O Sysop2z } {$O Sysop3 } {$O Sysop4 } +{$O Sysop5 } {$O Sysop6 } {$O Sysop7 } {$O Sysop7m } {$O Sysop8 } +{$O Sysop9 } {$O Sysop10 } {$O Sysop11 } {$O Mail0 } {$O Mail1 } +{$O Mail2 } {$O Mail3 } {$O Mail4 } {$O Mail5 } {$O Mail6 } +{$O Mail9 } {$O File0 } {$O File1 } {$O File2 } {$O File3 } +{$O File4 } {$O File5 } {$O File6 } {$O File7 } {$O File8 } +{$O File9 } {$O File10 } {$O File11 } {$O File12 } {$O File13 } +{$O File14 } {$O Archive1 } {$O Archive2 } {$O Archive3 } {$O Logon1 } +{$O Logon2 } {$O NewUsers } {$O Misc1 } {$O Misc2 } {$O Misc3 } +{$O Misc4 } {$O MiscX } {$O CUser } {$O Doors } {$O ExecBat } +{$O MyIO } {$O Menus2 } {$O Menus3 } {$O Menus4 } + +Const + OvrMaxSize = 60000; + BBSMaxHeapSpace = 40000; + +{$I LcBbs.Pas} + +Var + ExitSave : Pointer; + ExecFirst : Boolean; + NewMenuCmd: String; + +Procedure ErrorHandle; +{***************************************************************************** + * Note: if error occurs IN THIS PROCEDURE, * + * it is NOT executed again! That way an infinite loop is *avoided*.... * + *****************************************************************************} +Var + T:Text; + F:File; + S:String[80]; + VidSeg:Word; + X,Y:Integer; + C:Char; +Begin + ExitProc:=ExitSave; + If (ErrorAddr<>Nil) then + Begin + chdir(start_dir); + if (textrec(sysopf).mode=fmoutput) then + begin + writeln(sysopf,#3#8+'*>>'+#3#7+' Runtime error '+cstr(exitcode)+ + ' at '+date+' '+time+#3#8+' <<*'+#3#5+ + ' (Check ERR.LOG in main BBS dir)'); + flush(sysopf); close(sysopf); + end; + if (textrec(trapfile).mode=fmoutput) then + begin + writeln(trapfile,'*>> Runtime error '+cstr(exitcode)+' at '+date+' '+ + time+' <<*'); + flush(trapfile); close(trapfile); + end; + + assign(t,'err.log'); + {$I-} append(t); {$I+} + if (ioresult<>0) then + begin + rewrite(t); + append(t); + writeln(t,'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ'); + writeln(t,'Critical Error Log file - Contains screen images at instant of Error.'); + writeln(t,'The "²" character shows the cursor position at time of error.'); + writeln(t,'Note: You may periodically delete this file with no harm to the system,'); + writeln(t,'but note the following information:'); + writeln(t,'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'); +{***** + writeln(t,'Please notify Eric Oman that you have encountered a Critical Error.'); + writeln(t,'You will need to send this file to him, along with a short message'); + writeln(t,'stating - briefly - what events led up to the Critical Error, and whether'); + writeln(t,'or not the error was repeatable, and under what circumstances.'); + writeln(t); + writeln(t,'Eric can be reached at: * The Pointe BBS 313-885-1779'); + writeln(t,' Electric Eye ][ BBS 313-776-8928'); + writeln(t,' The Ozone BBS 313-689-2876'); + writeln(t,'( * -- Best chance ) Warp Speed BBS 313-544-0405'); + *****} + writeln(t,'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ'); + writeln(t); + end; + writeln(t); + if (serialnumber<>0) then + s:=' ('+cstr(serialnumber)+vercs+')' + else + s:=''; + writeln(t,'¯>¯ RT #'+cstr(exitcode)+' at '+date+' '+time+' BBS-Ver: '+ver+s); + if (useron) then begin + if (spd<>'KB') then s:='at '+spd+' baud' else s:='Locally'; + writeln(t,'¯>¯ User "'+allcaps(thisuser.name)+' #'+cstr(usernum)+ + '" was on '+s); + end; + writeln(t,'®®®®®®®®®®®®®®®®®®®®®®®®®®®® <®- Screen Image: -¯> ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯'); + if (mem[$0000:$0449]=7) then vidseg:=$B000 else vidseg:=$B800; + for y:=1 to 25 do + begin + s:=''; + for x:=1 to 80 do + begin + c:=chr(mem[vidseg:(160*(y-1)+2*(x-1))]); + if (c=#0) then c:=#32; + if ((x=wherex) and (y=wherey)) then c:=#178; + if ((x<>80) or ((x=80) and (c<>#32))) then s:=s+c; + end; + writeln(t,s); + end; + writeln(t,'®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®®*¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯'); + close(t); + + assign(f,'critical.err'); rewrite(f); close(f); setfattr(f,dos.hidden); + + sprint(#3#8+'*>>'+#3#7+' System error occured at '+date+' '+time+#3#8+' <<*'); + term_ready(TRUE); remove_port; {removeint(modemr.comport);} + writeln('*>> System error '+cstr(exitcode)+' at '+date+' '+time+' <<*'); + + if (exiterrors<>-1) then halt(exiterrors) else halt(254); + {* CRITICAL ERROR ERRORLEVEL *} + end; +end; + +Procedure MenuExec; +Var + Dt : LDateTimeRec; + Cmd,s : String; + I : Integer; + Aa,Abort,Next,Done:Boolean; +Begin + If (ExecFirst) then + Begin + ExecFirst:=FALSE; + Cmd:=NewMenuCmd; + NewMenuCmd:=''; + End Else MainMenuHandle(Cmd); + + if ((copy(cmd,1,2)='\\') and (thisuser.sl=255)) then begin + domenucommand(done,copy(cmd,3,length(cmd)-2),newmenucmd); + if (newmenucmd<>'') then cmd:=newmenucmd else cmd:=''; + end; + + If (Cmd='|') then + Begin + nl; sprint(#3#3+verline(1)); sprint(#3#3+verline(2)); nl; + pdt2dt(sitedatetime,dt); + sprint(#3#3+'Release date: '+#3#5+tch(cstr(dt.month))+'/'+ + tch(cstr(dt.day))+'/'+cstr(dt.year)+' '+tch(cstr(dt.hour))+':'+ + tch(cstr(dt.min))+':'+tch(cstr(dt.sec))+'.'+tch(cstr(dt.sec100))); + If (LicenseInfo<>'') then + Begin + nl; sprint(#3#3+'This version is licensed to:'); cl(5); prompt(' '); + aa:=allowabort; allowabort:=FALSE; abort:=FALSE; next:=FALSE; + s:=licenseinfo; + while (s<>'') do + if (pos(^J,s)<>0) then + begin + printa1(copy(s,1,pos(^J,s)-1),abort,next); + s:=copy(s,pos(^J,s)+1,length(s)-pos(^J,s)); + nl; prompt(' '); cl(5); + end else + begin + printa1(s,abort,next); s:=''; nl; + end; + allowabort:=aa; + end; + lastcommandgood:=TRUE; + end else + if ((cmd='=') and (cso)) then showmenucmds + else + if (cmd<>'') then + begin + newmenucmd:=''; + repeat domenuexec(cmd,newmenucmd) until (newmenucmd=''); + end; +end; + +Var + OvrPath,VerType : String; + I,RCode : Integer; + NeedToHangup : Boolean; + SyStatF : File of systatrec; +Begin + exitsave:=exitproc; + exitproc:=@errorhandle; + + MaxHeapSpace:=BBSMaxHeapSpace; + checksnow:=TRUE; directvideo:=FALSE; + + useron:=FALSE; usernum:=0; + getdir(0,start_dir); + + assign(systatf,'status.dat'); + {$I-} reset(systatf); {$I+} + if (ioresult<>0) then + begin + writeln; + writeln('Unable to find STATUS.DAT data file. This file is absolutely'); + writeln('*REQUIRED* to even load the BBS. If you cannot find your'); + writeln('STATUS.DAT data file, re-create one using the INIT package.'); + if (exiterrors<>-1) then halt(exiterrors) else halt(254); + end else begin + {$I-} read(systatf,systat); {$I+} + close(systatf); + end; + + ovrinit('BBS.OVR'); + ovrpath:=fsearch('BBS.OVR',getenv('PATH')); + if (ovrresult<>ovrok) then + begin + clrscr; writeln('Critical error: Overlay manager error.'); halt(1); + end; + if (systat.useems) then + begin + ovrinitems; if (ovrresult=ovrok) then overlayinems:=TRUE; + end; + ovrsetbuf(ovrmaxsize); ovrsetretry(ovrmaxsize div 2); + + initexecswap2:=initexecswap; + execwithswap2:=execwithswap; + shutdownexecswap2:=shutdownexecswap; + + findvertypeout(ovrpath,vercs,vertype,vertypes,serialnumber,licenseinfo,sitedatetime); + ver:=ver+' '+vertype; + + init; + + if (packbasesonly) then + begin + wfcmdefine; doshowpackbases; thisuser.ac:=thisuser.ac-[pause]; nl; + sprint(#3#5+'Message bases have been packed.'); + cursoron(TRUE); halt(0); + end; + mailread:=FALSE; smread:=FALSE; + + needtohangup:=wascriterr; { hang up if critical error last call! } + + repeat + write_msg:=FALSE; + sysopon:=not systat.localsec; + wantout:=not systat.localscreensec; + checksnow:=systat.cgasnow; + + wfcmenus(needtohangup); + needtohangup:=FALSE; + + useron:=FALSE; usernum:=0; + if (not doneday) then + begin + if (getuser) then newuser; + if (not hangup) then + begin + macok:=TRUE; + if (not hangup) then logon; + if (not hangup) then + begin + with thisuser do + begin + newdate:=laston; + if (not mbaseac(lastmsg)) then lastmsg:=1; + if (not fbaseac(lastfil)) then lastfil:=1; + board:=lastmsg; fileboard:=lastfil; + end; + batchtime:=0.0; numbatchfiles:=0; numubatchfiles:=0; hiubatchv:=0; + newcomptables; + + menustackptr:=0; for i:=1 to 8 do menustack[i]:=''; + + last_menu:=systat.allstartmenu+'.MNU'; + + if (not exist(systat.menupath+last_menu)) then + begin + sysoplog('"'+systat.menupath+last_menu+'" is MISSING. Loaded "MAIN.MNU" instead.'); + last_menu:='main.mnu'; + end; + curmenu:=systat.menupath+last_menu; readin; + + if (novice in thisuser.ac) then chelplevel:=2 else chelplevel:=1; + end; + + newmenucmd:=''; i:=1; + while ((i<=noc) and (newmenucmd='')) do + begin + if (cmdr[i].ckeys='FIRSTCMD') then + if (aacs(cmdr[i].acs)) then newmenucmd:='FIRSTCMD'; + inc(i); + end; + execfirst:=(newmenucmd='FIRSTCMD'); + while (not hangup) do menuexec; {*** main BBS loop ***} + end; + + if (quitafterdone) then + begin + elevel:=exitnormal; hangup:=TRUE; doneday:=TRUE; needtohangup:=TRUE; + end; + logoff; + if (not doneday) then sl1(#3#3+'Logoff '+#3#5+'['+dat+']'); + + if (textrec(sysopf1).mode=fmoutput) then + begin + {$I-} close(sysopf1); {$I+} + if (ioresult<>0) then writeln('Errors closing SLOGxxxx.LOG'); + end; + + if ((com_carrier) and (not doneday)) then + if (spd<>'KB') then needtohangup:=TRUE; + if (enddayf) then endday; + enddayf:=FALSE; + end; + until (doneday); + + if (needtohangup) then hangupphone; + reset(sysopf); close(sysopf); + term_ready(TRUE); remove_port; {removeint(modemr.comport);} + + if (exist('bbsdone.bat')) then shelldos(FALSE,'bbsdone.bat',rcode); + + textcolor(7); clrscr; textcolor(14); + WriteLn('[> TeleGard-X - Exited with ErrorLevel ',elevel,' at '+date+' '+time); + halt(elevel); +end. diff --git a/boarde.msg b/boarde.msg new file mode 100644 index 0000000..9cc25e5 --- /dev/null +++ b/boarde.msg @@ -0,0 +1,25 @@ +ÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍËÍÍÍÍÍÍÍÍÍÍËÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ= + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/boarder.msg b/boarder.msg new file mode 100644 index 0000000..f50cf1b --- /dev/null +++ b/boarder.msg @@ -0,0 +1 @@ +==:==============:==:==========:==:======================================== \ No newline at end of file diff --git a/brec17a2.pas b/brec17a2.pas new file mode 100644 index 0000000..c7f1f33 --- /dev/null +++ b/brec17a2.pas @@ -0,0 +1,233 @@ + +(***** BETA CONVERSION RECORDS *****) + + ulrec17a2= { UPLOADS.DAT : File base records } + record + name:string[40]; { area description } + filename:string[12]; { filename + ".DIR" } + dlpath, { download path } + ulpath:string[40]; { upload path } + namesl:byte; { req SL to see who ULed } + maxfiles:integer; { max files allowed } + password:string[20]; { password required } + arctype, { wanted archive type (1..maxarcs,0=inactive) } + cmttype:byte; { wanted comment type (1..3,0=inactive) } + fbdepth:integer; { file base dir depth } + fbstat:set of fbflags; { file base status vars } + acs:acstring; { access requirements } + {}sl:byte; { SL required } + {}dsl:byte; { DSL required } + {}ar:acrq; { AR flag required } + {}agereq:byte; { age required } + res:array[1..6] of byte; { RESERVED } + end; + + systatrec17a4= + record + bbsname:string[40]; {BBS's name } + bbsphone:string[12]; {BBS's phone # } + sysopfirst:string[12]; {SysOp's 1st name } + sysoplast:string[16]; {SysOp's 2nd name } + boardpw:string[20]; {newuser PW (if active) } + sysoppw:string[20]; {SysOp PW } + bbspw:string[20]; {board PW (if matrix) } + closedsystem:boolean; {if no new users accepted } + matrix:boolean; {if Shuttle Logon active } + alias:boolean; {if allow alias's } + clearmsg:boolean; {if clear scr. before msg } + fone:boolean; {if ph# PW's active } + multitask:boolean; {if BBS is multitasking } + bwindow:boolean; {if large window active } + lock300:boolean; {if lockout 300 baud } + wantquote:boolean; {/// } + mcimsg:boolean; {/// } + special:boolean; {WFC menu special effects } + localsec:boolean; {if local security on } + localscreensec:boolean; {whether local screen security } + autominlogon:boolean; {if automessage in logon } + bullinlogon:boolean; {if bulletins in logon } + lcallinlogon:boolean; {if last caller list in logon } + autochatopen:boolean; {if chat buffer auto-open } + yourinfoinlogon:boolean; {whether yourinfo in logon } + globaltrap:boolean; {if trap all users activity } + snowchecking:boolean; {whether snow checking on } + forcevoting:boolean; {manditory voting during logon } + offhooklocallogon:boolean;{take phone off hook when logon locally } + + hmsg:messages; {highest msg counter } + tfiledate:string[8]; {last Tfiles date } + lastdate:string[8]; {/// } + + callernum:longint; {# of callers } + users:integer; {# of users } + activetoday:integer; {TODAY's time-on count } + callstoday:integer; {TODAY's caller count } + msgposttoday:integer; {TODAY's post count } + emailtoday:integer; {TODAY's email count } + fbacktoday:integer; {TODAY's feedback count } + uptoday:integer; {TODAY's upload count } + newuk:integer; {TODAY's upload K count } + newusertoday:integer; {TODAY's new user count } + dntoday:integer; {TODAY's download count } + newdk:integer; {TODAY's download K count } + + gfilepath:string[79]; {GFILES path } + pmsgpath:string[79]; {Private mail path } + menupath:string[79]; {MENUS path } + tfilepath:string[79]; {TFILES path } + afilepath:string[79]; {alternate text files path } + trappath:string[79]; {user audit trap path } + temppath:string[79]; {"temp" directory path } + + lowtime,hitime:integer; {SysOp hours } + dllowtime,dlhitime:integer; {download hours } + b300lowtime,b300hitime:integer; {300 baud hours } + b300dllowtime,b300dlhitime:integer; {300 baud DL hours } + + app:integer; {user num to send new user application to } + guestuser:integer; {user num of guest user } + timeoutbell:integer; {mins before timeout bell } + timeout:integer; {mins before timeout } + + sysopcolor,usercolor:byte; {colors in chat mode } + bsdelay:byte; {backspacing delay } + tosysopdir:byte; {"To SysOp" file dir } + + comport:byte; {comport # } + maxbaud:word; {max baud } + init:string[40]; {init string } + hangup:string[40]; {hangup string } + offhook:string[40]; {phone off hook string } + answer:string[40]; {answer string } + + resultcode:array[1..2,0..4] of integer; {**-Result codes-** } + nocarrier:integer; {no carrier result code } + nodialtone:integer; {no dialtone result code } + busy:integer; {busy result code } + nocallinittime:integer; {reinit modem after x mins of inactivity } + tries:byte; {tries allowed for PW's } + + newsl,newdsl:byte; {new- } + newar:set of acrq; {user } + newac:set of uflags; {automatic } + newfp:integer; {settings } + + autosl,autodsl:byte; {auto- } + autoar:set of acrq; {validation } + autoac:set of uflags; {settings } + + ansiq:string[80]; {"do you want ANSI" string } + engage:string[79]; {engage chat string } + endchat:string[79]; {end chat string } + sysopin:string[79]; {if in sysop hours } + sysopout:string[79]; {if outside sysop hours } + note:array[1..2] of string[79]; {logon notes (L 1-2) } + lprompt:string[40]; {logon prompt (L 3) } + wait:string[79]; {sysop working string } + pause:string[79]; {pause string } + msg1:string[79]; {enter msg line 1 } + msg2:string[79]; {enter msg line 2 } + new1:string[79]; {newscan begin string } + new2:string[79]; {newscan done string } + read:string[79]; {Msg (S)can prompt } + auto1:string[79]; {auto msg title } + autom, {auto msg borders } + echoc:char; {echo char for PWs } + + uldlratio, {if UL/DL ratios on } + fileptratio:boolean; {if file pt ratios on } + fileptcomp, {file pt compensation ratio } + fileptcompbasesize:byte; {file pt base compensation size } + + timeallow, {time allowance } + callallow, {call allowance } + dlratio, {# DLs ratios } + dlkratio, {DL k ratios } + postratio:secrange; {post ratios } + + normpubpost,anonpubpost,anonpubread, {public mail SLs } + normprivpost,anonprivpost,anonprivread, {email SLs } + maxpubpost,maxprivpost, {max post/email per call } + maxfback,maxchat, {max feedback/pages per call } + maxwaiting,csmaxwaiting, {max mail waiting, normal/CS } + maxlines,csmaxlines:byte; {max lines in msg, normal/CS } + + sop,csop, {SysOp SL / CoSysOp SL } + msop,fsop, {Message SysOp SL / File SysOp SL } + spw, {SysOp PW at logon } + seepw, {see SysOp PWs remotely } + nodlratio, {no DL ratio checking } + nopostratio, {no post ratio checking } + nofilepts, {no file pts checking SL } + seeunval, {see unvalidated files SL } + dlunval, {download unval. files SL } + ulrefund:byte; {% time refund for ULs } + + eventwarningtime:integer; {time before event warning } + filearccomment:array[1..3] of string[80]; {BBS comment for ARC file } + filearcinfo:array[1..6] of filearcinforec; {ARC specs} + + minspaceforpost, {minimum K req'd for a post} + minspaceforupload:integer; {minimum K req'd for an upload} +postcredits:integer; {file points/upload credit compensation for posts} +ulvalreq:byte; {uploads require validation override SL} + +mmmmm:array[1..31] of byte; + + backsysoplogs:byte; {# back-days to keep SYSOP##.LOG} + compressbases:boolean; {whether to "compress" file/msg bases} + remdevice:string[10]; {remote output device } + userbaud:array[0..4] of integer; {user baud rates ... } + criterr:integer; {# critical errors occured today } + + searchdup:boolean; {search for dup. filenames when UL?} + istopwindow:boolean; {put SysOp window on top of screen?} + + arq9600rate:word; {baud rate to USE when 9600 ARQ result code} + allstartmenu:string[8]; {menu to start ALL users out on} + wfcblanktime:byte; {minutes after which to blank WFC menu} + validateallfiles:boolean; {validate all files automatically?} + maxintemp:integer; {max k-bytes allowed in TEMP\3\} + slogtype:byte; {output SysOp log to printer?} + stripclog:boolean; {strip color from SysOp log output?} + noforcerate:boolean; {whether to force baud rate} + rebootforevent:boolean; {reboot before events?} + minresume:integer; {minimum k-bytes to allow save for resume} + + res:array[1..123] of byte; {***-> reserved <-***} + end; + + boardrec17a5= { BOARDS.DAT : Message base records } + record + name:string[40]; { message base description } + filename:string[12]; { *.BRD data filename } + msgpath:string[40]; { messages pathname } + acs, { access requirement } + postacs, { post access requirement } + mciacs:acstring; { MCI usage requirement } + maxmsgs:byte; { max message count } + anonymous:anontyp; { anonymous type } + password:string[20]; { base password } + mbstat:set of mbflags; { message base status vars } + permindx:longint; { permanent index # } +{*}mbdepth:integer; { message base dir depth } + res:array[1..4] of byte; { RESERVED } + end; + + modemrec17a7= + record + waitbaud:word; { wait baud } + comport:byte; { comport number } + init:string[80]; { initialization string } + answer:string[40]; { answer string } + hangup:string[40]; { hangup string } + offhook:string[40]; { phone off-hook string } + nocallinittime:integer; { reinit modem after x mins of inactivity } + arq9600rate:word; { baud rate to USE when 9600 ARQ result code } + noforcerate:boolean; { whether to force baud rate} + nocarrier:integer; { no carrier result code } + nodialtone:integer; { no dialtone result code } + busy:integer; { busy result code } + resultcode:array[1..2,0..4] of integer; {**-Result codes-** } + end; + diff --git a/c.bat b/c.bat new file mode 100644 index 0000000..a103fed --- /dev/null +++ b/c.bat @@ -0,0 +1,2 @@ +c:\tp\tpc /$G+ /B /ic:\t\ /uc:\t\ /uc:\tp /m /l bbs.pas %2 %3 %4 %5 %6 + \ No newline at end of file diff --git a/c.~ba b/c.~ba new file mode 100644 index 0000000..74500a8 --- /dev/null +++ b/c.~ba @@ -0,0 +1,2 @@ +c:\tp\tpc /$G+ /ic:\t\ /uc:\t\ /uc:\tp /m /l bbs.pas %2 %3 %4 %5 %6 + \ No newline at end of file diff --git a/cbbs.pas b/cbbs.pas new file mode 100644 index 0000000..f48c009 --- /dev/null +++ b/cbbs.pas @@ -0,0 +1,110 @@ +uses dos; + +var f:text; + +function tch(i:string):string; +begin + if length(i)>2 then i:=copy(i,length(i)-1,2) else + if length(i)=1 then i:='0'+i; + tch:=i; +end; + +function cstr(i:integer):string; +var c:string; +begin + str(i,c); + cstr:=c; +end; + +function value(s:string):integer; +var n,n1:integer; +begin + val(s,n,n1); + if n1<>0 then begin + s:=copy(s,1,n1-1); + val(s,n,n1) + end; + value:=n; + if s='' then value:=0; +end; + +function time:string; +var r:registers; + h,m,s:string[4]; +begin + r.ax:=$2c00; intr($21,dos.registers(r)); + str(r.cx shr 8,h); str(r.cx mod 256,m); str(r.dx shr 8,s); + time:=tch(h)+':'+tch(m)+':'+tch(s); +end; + +function date:string; +var r:registers; + m,d,y:string[4]; +begin + r.ax:=$2a00; msdos(dos.registers(r)); str(r.cx,y); str(r.dx mod 256,d); + str(r.dx shr 8,m); + date:=tch(m)+'/'+tch(d)+'/'+tch(y); +end; + +function leapyear(yr:integer):boolean; +begin + leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0)); +end; + +function days(mo,yr:integer):integer; +var d:integer; +begin + d:=value(copy('312831303130313130313031',1+(mo-1)*2,2)); + if (mo=2) and leapyear(yr) then d:=d+1; + days:=d; +end; + +function daycount(mo,yr:integer):integer; +var m,t:integer; +begin + t:=0; + for m:=1 to (mo-1) do t:=t+days(m,yr); + daycount:=t; +end; + +function daynum(dt:string):integer; +var d,m,y,t,c:integer; +begin + t:=0; + m:=value(copy(dt,1,2)); + d:=value(copy(dt,4,2)); + y:=value(copy(dt,7,2))+1900; + for c:=1985 to y-1 do + if leapyear(c) then t:=t+366 else t:=t+365; + t:=t+daycount(m,y)+(d-1); + daynum:=t; + if y<1985 then daynum:=0; +end; + +function dat:string; +const mon:array [1..12] of string[3] = + ('Jan','Feb','Mar','Apr','May','Jun', + 'Jul','Aug','Sep','Oct','Nov','Dec'); +var ap,x,y:string; + i:integer; +begin + case daynum(date) mod 7 of + 6:x:='Mon'; 3:x:='Fri'; + 0:x:='Tue'; 4:x:='Sat'; + 1:x:='Wed'; 5:x:='Sun'; + 2:x:='Thu'; + end; + y:=mon[value(copy(date,1,2))]; + x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2))); + y:=time; i:=value(copy(y,1,2)); + if i>11 then ap:='pm' else ap:='am'; + if i>12 then i:=i-12; + if i=0 then i:=12; + dat:=cstr(i)+copy(y,3,3)+' '+ap+' '+x; +end; + +begin + assign(f,paramstr(1)); rewrite(f); + writeln(f,'lastcompiled=''Last official compilation date: < '+dat+' >'';'); + close(f); +end. diff --git a/cc.bat b/cc.bat new file mode 100644 index 0000000..e4f7769 --- /dev/null +++ b/cc.bat @@ -0,0 +1,14 @@ +echo off +c: +cd \tp\telegard +del *.bak +ds en +echo  +type baa2.ans +echo  +cecho $07 "C:\T> " $0b "\com\tp\tpc /m /l " $09 "bbs.pas" $0b " /DAlpha" +cbbs lcbbs.pas +c:\com\tp\tpc /m /l bbs.pas /DAlpha /uc:\com\tp +mabs1 +rem mabs 2 mylicens.dat 1 +echo  diff --git a/change.me b/change.me new file mode 100644 index 0000000..92b7527 --- /dev/null +++ b/change.me @@ -0,0 +1,168 @@ +File CONV17A.PAS: + write('Telegard Conversion for '+ver1+' ^P¯¯¯¯¯¯¯¯¯^P '+ver); + writeln('This program is provided to add/modify/create files used by Telegard to'); + write('Thank you for choosing Telegard!'); +File CONV17A9.PAS: + write(' Telegard Conversion for '+ver1+' ^P¯¯¯¯¯¯¯¯¯^P '+ver); + writeln('This program is provided to add/modify/create files used by Telegard to'); + write('Thank you for choosing Telegard!'); +File CONV18A.PAS: + write(' Telegard Conversion for '+ver1+' ^P¯¯¯¯¯¯¯¯¯^P '+ver); + writeln('This program is provided to add/modify/create files used by Telegard to'); + write('Thank you for choosing Telegard!'); +File FILE5.PAS: + print('Telegard(R) Mini-DOS(R) Version '+ver); + print(' (C)Copyright 1988,89,90 The Telegard Team'); + print('Licensed for internal usage in Telegard v'+ver); + print(s+' - Telegard archive conversion command.'); + print('Telegard will convert from the one archive format to the other.'); + print(s+' - Telegard archive de-compression command.'); + print('configured into Telegard via System Configuration.'); + print(s+' - Telegard archive compression command.'); + print('configured into Telegard via System Configuration.'); + print('Type "EXIT" to return to Telegard.'); +File INIT.PAS: +(*> Telegard Bulletin Board System - Copyright 1988,89,90 by <*) + bbsname:='Telegard BBS'; + {* A-32767.1 is the "Greetings from Telegard" message *} + note[1]:='Enter your Telegard NAME or USER NUMBER'; + waiting:=1; {* A-32767.1 -- "Greetings from Telegard" message *} + title:='Greetings, new Telegard SysOp!!'; + as:='The Telegard Team'; + real:='The Telegard Team'; + alias:='The Telegard Team'; + name:='The Telegard Team'; + citystate:='Telegard Development HQ, MI'; + msg:='Telegard system initialized on '+date+' at '+time+'.'; + ttl('Creating Telegard directory paths'); + ttl('Creating Telegard data files'); + write('Telegard v'+ver+' Initialization Utility - Copyright 1988,89,90 by'); + writeln('Telegard has already been initialized!'); + writeln('that will be used by Telegard. Each directory will be created'); + writeln('GFILES pathname. This is the directory where the Telegard data'); + writeln('files and miscellaneous Telegard text files will be located.'); + writeln('files (*.BRD, *.MIX, *.TRE) used by Telegard for both private'); + writeln('MENUS pathname. This is the directory where the Telegard menu'); + writeln('TFILES pathname. This is the directory where the Telegard'); + writeln('AFILES pathname. This is the directory where the Telegard'); + writeln('TRAP pathname. This is the directory where Telegard will'); + writeln('TEMP pathname. Telegard uses this directory to convert between'); + writeln('SWAP pathname. This is the directory where Telegard''s swap'); + star('Telegard BBS installed and initialized successfully!'); + star('Thanks for trying Telegard!'); +File INIT16D3.PAS: + bbsname:='Telegard BBS'; + {* A-32767.1 is the "Greetings from Telegard" message *} + note[1]:='Enter your Telegard NAME or USER NUMBER'; + waiting:=1; {* A-32767.1 -- "Greetings from Telegard" message *} + title:='Greetings from Telegard'; + msg:='Telegard files initialized on '+date+' '+time+'.'; + ttl('Creating Telegard directory paths'); + ttl('Creating Telegard data files'); + clreol; write(' Initialization Utility for Telegard version '+ver); + writeln('Telegard has already been initialized!'); + writeln('that will be used by Telegard. Each directory will be created'); + writeln('GFILES pathname. This is the directory where the Telegard data'); + writeln('files and miscellaneous Telegard text files will be located.'); + writeln('MSGS pathname. This is the directory where the Telegard message'); + writeln('MENUS pathname. This is the directory where the Telegard menu'); + writeln('TFILES pathname. This is the directory where the Telegard'); + star('Telegard BBS installed and initialized successfully!'); + star('Thanks for trying Telegard!'); +File INIT16E1.PAS: + bbsname:='Telegard BBS'; + {* A-32767.1 is the "Greetings from Telegard" message *} + note[1]:='Enter your Telegard NAME or USER NUMBER'; + waiting:=1; {* A-32767.1 -- "Greetings from Telegard" message *} + title:='Greetings from Telegard'; + description:='A NEW Telegard Event'; + msg:='Telegard files initialized on '+date+' '+time+'.'; + ttl('Creating Telegard directory paths'); + ttl('Creating Telegard data files'); + clreol; write(' Initialization Utility for Telegard version '+ver); + writeln('Telegard has already been initialized!'); + writeln('that will be used by Telegard. Each directory will be created'); + writeln('GFILES pathname. This is the directory where the Telegard data'); + writeln('files and miscellaneous Telegard text files will be located.'); + writeln('directory paths used by Telegard, including private mail (EMAIL).'); + writeln('Located in these paths are the text of the Telegard messages.'); + writeln('MENUS pathname. This is the directory where the Telegard menu'); + writeln('TFILES pathname. This is the directory where the Telegard'); + writeln('AFILES pathname. This is the directory where the Telegard'); + writeln('TRAP pathname. This is the directory where Telegard will'); + writeln('TEMP pathname. Telegard uses this directory to convert between'); + star('Telegard BBS installed and initialized successfully!'); + star('Thanks for trying Telegard!'); +File INITP.PAS: + description:='Telegard Nightly Events'; + description:='A NEW Telegard Event'; +File MAIL1.PAS: + s:=#3+cstr(tear_color)+'--- Telegard v'+ver; +File MINITERM.PAS: +(*> MINITERM.PAS - Telegard Communications Program <*) + wcenter('Telegard MiniTerm - Version '+ver,15,2); +File MISC1.PAS: + sprint('^5Telegard Time Bank v'+ver); +File MISCX.PAS: + sl1('\ Telegard SysOp Log for '+date+': /'); + writeln(sysopf1,'>> Telegard SysOp Log for '+nam+': <<'); +File MMODEM.PAS: + cwriteat(2,25,'Telegard:'+#3#14); +File SEPMSGS.PAS: + star('Each message base in Telegard can now occupy its own, seperate directory'); + star('Message directories will be created off of your current Telegard MSGS\'); +File SYSOP2A.PAS: +(*> Telegard Bulletin Board System - Copyright 1988,89,90 by <*) + print('This is the baud rate that Telegard will use when waiting for calls'); + print('This is the baud rate Telegard will USE between Telegard and your'); + print('These are communications flags used by Telegard.'); +File T2T.PAS: + backtotag:boolean; { CONVERTING TO TELEGARD .. } + ttl('Converting "NAMES.LST" to Telegard format'); + ttl('Converting "USER.LST" to Telegard format'); + ttl('Converting "BOARDS.DAT" to Telegard format'); + ttl('Converting "FBOARDS.DAT" to Telegard format ("UPLOADS.DAT")'); + ttl('Converting "VOTING.DAT" to Telegard format.'); + write(' Conversion for TAG '+tag_ver+' ^Q®®®®®-¯¯¯¯¯^P Telegard '+s_ver); + writeln('TAG '+tag_ver+' to the proper formats used by Telegard '+s_ver+'.'); + writeln('It may ALSO be used to convert from Telegard format to TAG.'); + writeln(' TAG '+tag_ver+' Telegard '+s_ver); + writeln(' already in the correct Telegard '+s_ver+' format.'); + writeln('1. From TAG to Telegard format'); + writeln('2. From Telegard to TAG format'); + writeln('such files are here, and will be used to create the Telegard'); + writeln('equivalents in your Telegard paths.'); + textcolor(15); writeln('Enter your Telegard MAIN BBS pathname.'); + writeln('This step is involved to ensure you have a version of Telegard'); + textcolor(9); write('Telegard Path: '); infield(tgpath,40); + textcolor(15); writeln('Enter your Telegard MAIN BBS pathname.'); + writeln('The Telegard file STATUS.DAT should exist in this directory.'); + textcolor(9); write('Telegard Path: '); infield(tgpath,40); + else writeln('TO TELEGARD FORMAT'); + textcolor(9); write('Telegard Path: '); textcolor(15); writeln(tgpath); + writeln('Now you need to enter your Telegard MSGS directory, where you'); + textcolor(9); write('Telegard MSGS Path: '); infield(tmsgpath,40); + writeln('Convert Telegard '+s_ver+' ^P¯¯¯¯¯¯¯¯¯^P TAG '+tag_ver) + writeln('Convert TAG '+tag_ver+' ^P¯¯¯¯¯¯¯¯¯^P Telegard '+s_ver); + writeln('If Telegard data files are not in version '+s_ver+' format,') + if (not backtotag) then write('Thank you for choosing Telegard!') + else write('Well, thanks for TRYING Telegard!'); +File TA2Z.PAS: + textcolor(15); write('CONVERSION UTILITY for Telegard '+ver+': '); + writeln('your Telegard v'+ver+' BBS to the newer .ZIP format. PKZIP.EXE'); + elog('Telegard v'+ver+' ARC ---> ZIP file conversion utility'); + write('Thank you for choosing Telegard!'); +File TMU.PAS: +program TelegardMasterUtility; + #3#14+'for Telegard '+ +File SYSOP6.PAS: + description:='A NEW Telegard Event'; +File SYSOP7.PAS: + writeln(f,'New TeleGard-X Menu'); + ldesc:='(XXX)New TeleGard-X Command'; + sprint(#3#3+'TeleGard-X Menu Editor'); +File COMMON.PAS: + s:='TeleGard-X Bulletin Board System, Version '+ver; +File COMMON1.PAS: + writeln(trapfile,'***** TeleGard-X User Audit - '+nam+' on at '+date+' '+time+' *****'); + tc(11); writeln('[> Type "EXIT" to return to TeleGard-X.'); diff --git a/coconfig.pas b/coconfig.pas new file mode 100644 index 0000000..6d0c2ce --- /dev/null +++ b/coconfig.pas @@ -0,0 +1,800 @@ +program coconfig; + +{$M 35000,0,1000} + +uses myio, + {rcg11172000 hhmm...what's turbo3 do?} + {crt, dos, turbo3;} + crt, dos; + +{$I func.pas} + +type cfilterrec=array[0..255] of byte; + colorset=set of #0..#255; + +var cfilterf:file of cfilterrec; + cfilter:cfilterrec; + cfilter_name:string; + changed:boolean; + +const CURSOR_COLOR = 15; + default_cfilter:cfilterrec= + (9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,11,9,9,9,9,11,11,11,9,9,9,9,9,9, + 14,14,14,14,14,14,14,14,14,14,11,11,11,9,11,11, + 9,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, + 11,11,11,11,11,11,11,11,11,11,11,11,11,11,9,9, + 11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, + 11,11,11,11,11,11,11,11,11,11,11,11,11,11,9,9, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,9,13,13,13,13,13,13,13,13,13,13,13,13,13, + 13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13, + 13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9); + + +{rcg11172000 added by me.} +procedure CursorOn(flag:boolean); +begin + writeln('STUB: bb.pas; CursorOn()...'); +end; +{rcg11172000 adds end.} + + +procedure textset(f,b:byte); +begin + textcolor(f); + textbackground(b); +end; + +function cstr(i:longint):string; +var c:string; +begin + str(i,c); + cstr:=c; +end; + +function mln(s:string; len:integer):string; +begin + while (length(s)'') then + write('Editing "'+cfilter_name+'"') + else + write('New file'); + if (changed) then cwrite(#3#16+' * '); + textset(7,0); +end; + +procedure initchrsettings; +var i,x,y:integer; +begin + textset(0,7); box(8,32,1,67,14); window(1,1,80,25); + + cwriteat(32,6,'Ã'); + textset(7,0); for i:=1 to 34 do write('Ä'); + textset(0,7); write('´'); + + cwriteat(32,12,'Æ'); + for i:=1 to 34 do write('Í'); + write('µ'); + + gotoxy(33,13); for i:=1 to 34 do write(' '); + updateeditingline; + + cwriteat(40,1,#3#15+#2#1+' Character Settings '); + + i:=32; + for y:=3 to 10 do begin + if (y=6) then inc(y); + for x:=34 to 65 do begin + putscreen(x,y,i,7); + inc(i); + end; + end; +end; + +procedure updatechrsettings(uset:colorset; col:integer); +var i,x,y:integer; +begin + i:=32; + for y:=3 to 10 do begin + if (y=6) then inc(y); + for x:=34 to 65 do begin + if (chr(i) in uset) then + if (col=-1) then + putscreen(x,y,i,cfilter[i]) + else + putscreen(x,y,i,col); + inc(i); + end; + end; +end; + +procedure docolortable(editset:colorset; cx,cy:integer; var feedback:char); +var ctwind,undercursor:windowrec; + curb,curf,oldb,oldf,i:integer; + c:char; + col,oldcol,bb:byte; + abort,done:boolean; + + procedure putwithbg(x,y,col:byte; c:char); + var oldattr:byte; + begin + putscreen(x,y,ord(c),(getscreen(x,y,1) and 240)+col); + end; + + procedure putcursor; + begin + savescreen(undercursor,cx+curb*3+1,cy+curf+1,cx+curb*3+5,cy+curf+3); + putwithbg(cx+curb*3+1, cy+curf+1, CURSOR_COLOR, 'Ú'); + putwithbg(cx+curb*3+2, cy+curf+1, CURSOR_COLOR, 'Ä'); + putwithbg(cx+curb*3+3, cy+curf+1, CURSOR_COLOR, 'Ä'); + putwithbg(cx+curb*3+4, cy+curf+1, CURSOR_COLOR, 'Ä'); + putwithbg(cx+curb*3+5, cy+curf+1, CURSOR_COLOR, '¿'); + putwithbg(cx+curb*3+1, cy+curf+2, CURSOR_COLOR, '³'); + putwithbg(cx+curb*3+5, cy+curf+2, CURSOR_COLOR, '³'); + putwithbg(cx+curb*3+1, cy+curf+3, CURSOR_COLOR, 'À'); + putwithbg(cx+curb*3+2, cy+curf+3, CURSOR_COLOR, 'Ä'); + putwithbg(cx+curb*3+3, cy+curf+3, CURSOR_COLOR, 'Ä'); + putwithbg(cx+curb*3+4, cy+curf+3, CURSOR_COLOR, 'Ä'); + putwithbg(cx+curb*3+5, cy+curf+3, CURSOR_COLOR, 'Ù'); + oldb:=curb; oldf:=curf; + end; + + procedure delcursor; + begin + removewindow1(undercursor); + end; + + procedure setupcolortable; + var x,y:integer; + begin + setwindow(ctwind,cx,cy,cx+27,cy+19,0,7,8); + window(cx+2,cy+2,cx+25,cy+18); + + gotoxy(1,1); + for y:=0 to 15 do begin + textcolor(y); + for x:=0 to 7 do begin + textbackground(x); + write(' x '); + end; + end; + window(cx,cy,cx+27,cy+19); + + cwriteat(6,1,#3#15+#2#1+' Color Selection: '); + + window(1,1,80,25); + + cwriteat(34,22,#3#14+#2#0+';: '+#3#11+'Save color selection'); + cwriteat(34,23,#3#14+#2#0+'ESC: '+#3#11+'Abort'); + + curb:=(col and 112) shr 4; curf:=col and 15; + putcursor; + end; + +begin + i:=32; + while (i<=255) do begin + if (chr(i) in editset) then begin + col:=cfilter[i]; + i:=255; + end; + inc(i); + end; + oldcol:=col; + + setupcolortable; + + abort:=FALSE; done:=FALSE; + while (not done) do begin + c:=upcase(readkey); + case ord(c) of + 0:case ord(readkey) of + ARROW_HOME :curb:=0; + ARROW_UP :if (curf>0) then dec(curf); + ARROW_PGUP :curf:=0; + ARROW_LEFT :if (curb>0) then dec(curb); + ARROW_RIGHT:if (curb<7) then inc(curb); + ARROW_END :curb:=7; + ARROW_DOWN :if (curf<15) then inc(curf); + ARROW_PGDN :curf:=15; + end; + 13:done:=TRUE; + 27:begin abort:=TRUE; done:=TRUE; end; + 49..56,67:begin feedback:=c; abort:=TRUE; done:=TRUE; end; + end; + if ((curf<>oldf) or (curb<>oldb)) then begin + delcursor; + putcursor; + col:=(curb shl 4)+curf; + updatechrsettings(editset,col); + end; + end; + + if (not abort) then begin + if (not changed) then begin + changed:=TRUE; + updateeditingline; + end; + i:=32; + while (i<=255) do begin + if (chr(i) in editset) then cfilter[i]:=col; + inc(i); + end; + end else + updatechrsettings(editset,-1); + + gotoxy(34,22); clreol; gotoxy(34,23); clreol; + removewindow1(ctwind); +end; + +function allcaps(s:string):string; +var i:integer; +begin + for i:=1 to length(s) do s[i]:=upcase(s[i]); + allcaps:=s; +end; + +procedure getsetchr(var sc:char; var cx,cy:byte); +var ox,oy:byte; + c:char; + done:boolean; + + procedure revcursor(x,y:byte); + begin + putscreen(x,y,getscreen(x,y,0),255-getscreen(x,y,1)); + end; + +begin + ox:=cx; oy:=cy; + + revcursor(cx,cy); + + done:=FALSE; + while (not done) do begin + c:=upcase(readkey); + case ord(c) of + 0:case ord(readkey) of + ARROW_HOME :cx:=34; + ARROW_UP :if (cy>3) then begin dec(cy); if (cy=6) then cy:=5; end; + ARROW_PGUP :cy:=3; + ARROW_LEFT :if (cx>34) then dec(cx); + ARROW_RIGHT:if (cx<65) then inc(cx); + ARROW_END :cx:=65; + ARROW_DOWN :if (cy<10) then begin inc(cy); if (cy=6) then cy:=7; end; + ARROW_PGDN :cy:=10; + end; + 13:begin + sc:=chr(getscreen(cx,cy,0)); + done:=TRUE; + end; + 27:done:=TRUE; + end; + if ((cx<>ox) or (cy<>oy)) then begin + revcursor(ox,oy); + ox:=cx; oy:=cy; + revcursor(cx,cy); + end; + end; + revcursor(cx,cy); +end; + +function ritr(c:char; len:integer):string; +var s:string; + i:integer; +begin + s:=''; + for i:=1 to len do s:=s+c; + ritr:=s; +end; + +procedure docwindow(var wind:windowrec; y:integer; s:string); +var xx,x1,y1,x2,y2:integer; + sx,sy,sz:byte; +begin + sx:=wherex; sy:=wherey; sz:=textattr; + x1:=36-(length(s) div 2); y1:=y; + x2:=x1+length(s)+8; y2:=y+4; + xx:=length(s); + savescreen(wind,x1,y1,x2,y2); + cwriteat(x1,y1, #3#4+#2#0+'ÜÜÜÜ'+ritr('Ü',xx)+'ÜÜÜÜ'); + cwriteat(x1,y1+1,#3#14+#2#4+' Ûßß'+ritr('ß',xx)+'ßßÛ '); + cwriteat(x1,y1+2,#3#14+#2#4+' Û '+s+' Û '); + cwriteat(x1,y1+3,#3#14+#2#4+' ÛÜÜ'+ritr('Ü',xx)+'ÜÜÛ '); + cwriteat(x1,y1+4,#3#4+#2#0+ 'ßßßß'+ritr('ß',xx)+'ßßßß'); + gotoxy(sx,sy); textattr:=sz; +end; + +var newf,oldf:file; + buff:array[1..16384] of byte; + +procedure killoldcode(fname:string); +var tempwind:windowrec; + fspecpath,s1:dirstr; + fspecname,s2:namestr; + s3:extstr; + j:longint; + numread:word; + bb:byte; +begin + docwindow(tempwind,10,fname+': Removing old filter.'); + fsplit(fname,s1,s2,s3); + assign(newf,s1+s2+'.$$$'); + {$I-} rewrite(newf,1); {$I+} + if (ioresult<>0) then begin + removewindow1(tempwind); + docwindow(tempwind,10,s1+s2+'.$$$: Unable to create.'); + delay(1000); + removewindow1(tempwind); + close(oldf); + end else begin + seek(oldf,0); blockread(oldf,bb,1,numread); blockread(oldf,bb,1,numread); + repeat blockread(oldf,bb,1,numread) until ((chr(bb)=';') or (eof(oldf))); + if (not eof(oldf)) then + repeat + blockread(oldf,buff,16384,numread); + blockwrite(newf,buff,numread); + until (numread<16384); + close(oldf); close(newf); + erase(oldf); rename(newf,fname); + assign(oldf,fname); reset(oldf); + removewindow1(tempwind); + end; +end; + +function addthefilter(fname:string; cfiltername:string):boolean; +var tempwind:windowrec; + cfcode:string; + fspecpath,s1:dirstr; + fspecname,s2:namestr; + s3:extstr; + numread:word; + j:integer; +begin + addthefilter:=TRUE; + cfcode:=^T+'c'+cfiltername+';'; + assign(oldf,fname); + {$I-} reset(oldf,1); {$I+} + if (ioresult<>0) then begin + docwindow(tempwind,10,fname+': Unable to open.'); + delay(1000); + removewindow1(tempwind); + addthefilter:=FALSE; + end else begin + seek(oldf,0); blockread(oldf,buff,2,numread); + if ((chr(buff[1])=^T) and (chr(buff[2])='c')) then killoldcode(fname); + fsplit(fname,s1,s2,s3); + assign(newf,s1+s2+'.$$$'); + {$I-} rewrite(newf,1); {$I+} + if (ioresult<>0) then begin + docwindow(tempwind,10,s1+s2+'.$$$: Unable to create.'); + delay(1000); + removewindow1(tempwind); + close(oldf); + addthefilter:=FALSE; + end else begin + for j:=1 to length(cfcode) do buff[j]:=ord(cfcode[j]); + blockwrite(newf,buff,length(cfcode)); + reset(oldf,1); + repeat + blockread(oldf,buff,16384,numread); + blockwrite(newf,buff,numread); + until (numread<16384); + close(oldf); close(newf); + erase(oldf); rename(newf,fname); + end; + end; +end; + +procedure addfilters; +var oldf,newf:file; + savescr,tempwind:windowrec; + dirinfo:searchrec; + fs:array[1..110] of string[12]; + tagstat:array[1..110] of boolean; + fspecpath,s1:dirstr; + fspecname,s2:namestr; + s3:extstr; + fspec,fname,cfname,cfcode:string; + numread:word; + numfs,i,cx,cy,ci,ox,oy,oi:integer; + c:char; + bb:byte; + abort,done,noneyet:boolean; + + function cxp1(i:integer):byte; + begin + cxp1:=((i-1) mod 5)+1; + end; + + function cxp(i:integer):byte; + begin + cxp:=16*(cxp1(i)-1)+2; + end; + + function cyp(i:integer):byte; + begin + cyp:=((i-1) div 5)+1; + end; + + procedure putcursor; + var i,x,y:integer; + begin + x:=cxp(oi); y:=cyp(oi); + for i:=x to x+13 do putscreen(i,y,getscreen(i,y,0),30); + end; + + procedure delcursor; + var i,x,y:integer; + begin + x:=cxp(oi); y:=cyp(oi); + for i:=x to x+13 do putscreen(i,y,getscreen(i,y,0),14); + end; + + procedure tagit(i:integer); + begin + tagstat[i]:=not tagstat[i]; + if (tagstat[i]) then + putscreen(cxp(i)-1,cyp(i),ord('*'),10) + else + putscreen(cxp(i)-1,cyp(i),ord(' '),10); + end; + + procedure doaddfilters; + var j:longint; + i,savci:integer; + begin + delcursor; savci:=ci; + + fsplit(cfilter_name,s1,s2,s3); cfname:=s2+s3; + + setwindow(tempwind,11,9,67,14,9,1,8); textset(9,1); clrscr; + window(1,1,80,25); + cwriteat(14,11,#3#11+#2#1+'Color filter filename:'); + cwriteat(14,12,#3#9+#2#1+':'); + cursoron(TRUE); infield1(15,12,cfname,50); cursoron(FALSE); + removewindow1(tempwind); + + if (cfname<>'') then begin + cfcode:=^T+'c'+cfname+';'; + for i:=1 to numfs do + if (tagstat[i]) then begin + oi:=i; putcursor; + if (addthefilter(fspecpath+fs[i],cfname)) then tagit(i); + delcursor; + end; + end; + ci:=savci; oi:=ci; + putcursor; + end; + +begin + setwindow(savescr,1,1,80,25,14,0,0); clrscr; + + cursoron(TRUE); + textcolor(11); writeln(' Enter filespec to edit:'); + textcolor(9); write(' :'); + fspec:='*.MSG'; + infield1(wherex,wherey,fspec,76); fspec:=fexpand(allcaps(fspec)); + fsplit(fspec,fspecpath,fspecname,s3); + cursoron(FALSE); + if (fspec='') then exit; + clrscr; + + findfirst(fspec,anyfile-directory,dirinfo); + if (doserror<>0) then begin + docwindow(tempwind,10,'No files found.'); + delay(1000); + removewindow1(tempwind); + end else begin + ci:=1; + while ((ci<=110) and (doserror=0)) do begin + fs[ci]:=dirinfo.name; tagstat[ci]:=FALSE; + findnext(dirinfo); + inc(ci); + end; + numfs:=ci-1; + textcolor(14); + for ci:=1 to numfs do + cwriteat(cxp(ci),cyp(ci),mln(fs[ci],12)); + + cwriteat(1,25,#3#14+'SPACE: '+#3#11+'Tag files '+ + #3#14+'A: '+#3#11+'Tag all '+ + #3#14+';: '+#3#11+'Go! '+ + #3#14+'ESC: '+#3#11+'Done'); + + ci:=1; oi:=1; putcursor; + + abort:=FALSE; done:=FALSE; + while (not done) do begin + c:=upcase(readkey); + case ord(c) of + 0:case ord(readkey) of + ARROW_HOME :ci:=(cyp(ci)-1)*5+1; + ARROW_UP :dec(ci,5); + ARROW_PGUP :ci:=cxp1(ci); + ARROW_LEFT :dec(ci); + ARROW_RIGHT:inc(ci); + ARROW_END :ci:=(cyp(ci)-1)*5+5; + ARROW_DOWN :inc(ci,5); + ARROW_PGDN :begin + ci:=(cyp(numfs)-1)*5+cxp1(ci); + if (ci>numfs) then dec(ci,5); + end; + end; + 13:begin + noneyet:=TRUE; + for i:=1 to numfs do + if (tagstat[i]) then noneyet:=FALSE; + if (noneyet) then tagit(ci); + doaddfilters; + end; + 27:begin abort:=TRUE; done:=TRUE; end; + 32:begin tagit(ci); inc(ci); end; + 65:for i:=1 to numfs do tagit(i); + end; + if (ci<>oi) then begin + if (ci<1) then ci:=1; + if (ci>numfs) then ci:=numfs; + delcursor; oi:=ci; putcursor; + end; + end; + delcursor; + end; + + removewindow1(savescr); +end; + +var doswindow,askwindow:windowrec; + allset,set1,set2,set3,set4,set5,set6,set7,set8:colorset; + editset:colorset; + dirinfo:searchrec; + setname:string; + dosx,dosy,i,j,k:integer; + c,feedback,setc1,setc2:char; + sx,sy:byte; + done,isnew:boolean; + +procedure definesets; +begin + set1:=['A'..'Z']; + set2:=['a'..'z','"','''',':',';','?','\','`','|']; + set3:=['0'..'9']; + set4:=[#179..#223]; + set5:=[#176..#178]; +{ set6:= } + set7:=['(',')','<','>','[',']','{','}']; + set8:=['!','#','$','%','&','*','@','^']; + + allset:=[#0..#255]; + set6:=allset-set1-set2-set3-set4-set5-set7-set8; +end; + +procedure exite(i:integer); +begin + clrscr; + removewindow1(doswindow); + gotoxy(dosx,dosy); + cursoron(TRUE); + halt(i); +end; + +procedure savecfilter; +var tempwind:windowrec; +begin + if (cfilter_name='') then begin + setwindow(tempwind,11,9,67,14,9,1,8); textset(9,1); clrscr; + window(1,1,80,25); + cwriteat(14,11,#3#11+#2#1+'Save color filter as:'); + cwriteat(14,12,#3#9+#2#1+':'); + cursoron(TRUE); infield1(15,12,cfilter_name,50); cursoron(FALSE); + removewindow1(tempwind); + end; + if (cfilter_name<>'') then begin + assign(cfilterf,cfilter_name); + {$I-} rewrite(cfilterf); {$I+} + if (ioresult<>0) then begin + docwindow(tempwind,10,cfilter_name+': Unable to create.'); + delay(1000); + removewindow1(tempwind); + end else begin + {$I-} write(cfilterf,cfilter); {$I+} + if (ioresult<>0) then begin + docwindow(tempwind,10,cfilter_name+': Unable to write color filter.'); + delay(1000); + removewindow1(tempwind); + end else begin + changed:=FALSE; + updateeditingline; + updatechrsettings(allset,-1); + end; + close(cfilterf); + end; + end; +end; + +begin + infield_out_fgrd:=15; + infield_out_bkgd:=1; + infield_inp_fgrd:=0; + infield_inp_bkgd:=7; + infield_arrow_exit:=FALSE; + + dosx:=wherex; dosy:=wherey; + checkvidseg; + cursoron(FALSE); + savescreen(doswindow,1,1,80,25); + clrscr; + + if ((paramcount>0) and (paramstr(1)<>'')) then + cfilter_name:=paramstr(1) + else + cfilter_name:=''; +(* begin + cursoron(TRUE); + textcolor(11); writeln('Enter color configuration filename'); + textcolor(9); write(':'); + infield(cfilter_name,78); cfilter_name:=allcaps(cfilter_name); + cursoron(FALSE); + clrscr; + end;*) + + if (paramcount>1) then begin + writeln; + cwrite(#3#9+'þ '+#3#11+'Color filter name: "'+cfilter_name+'"'); + writeln; writeln; + j:=0; + for i:=2 to paramcount do begin + findfirst(paramstr(i),anyfile-directory,dirinfo); + while (doserror=0) do begin + cwrite(#3#9+'þ '+#3#11+dirinfo.name+#3#9+' - '+#3#11); + if (addthefilter(dirinfo.name,cfilter_name)) then begin + cwrite('Done.'); + inc(j); + end else + cwrite('Unable to add color filter!'^G^G); + writeln; + findnext(dirinfo); + end; + end; + writeln; + cwrite(#3#9+'þ '+#3#11+'Added color filter to '+#3#15+cstr(j)+#3#11+' file'); + if (j<>1) then cwrite('s'); + cwrite('.'); + writeln; + delay(3000); + exite(0); + end; + + isnew:=FALSE; + if (cfilter_name<>'') then begin + assign(cfilterf,cfilter_name); + {$I-} reset(cfilterf); {$I+} + if (ioresult=0) then begin + {$I-} read(cfilterf,cfilter); {$I+} + if (ioresult<>0) then begin end; + close(cfilterf); + end else + isnew:=TRUE; + end else + isnew:=TRUE; + + if (isnew) then begin + cfilter:=default_cfilter; +{ cwriteat(1,1,#3#12+'ÄÄ '+#3#14+'NEW FILE'+#3#12+' ÄÄ'); + delay(1000);} + clrscr; + end; + + changed:=FALSE; + definesets; + initchrsettings; + updatechrsettings(allset,-1); + + cwriteat(34,16,#2#0+#3#14+'1-8: '+#3#11+'Edit pre-defined set'); + cwriteat(34,17,#2#0+#3#14+' A: '+#3#11+'Add filter to text files'); + cwriteat(34,18,#2#0+#3#14+' C: '+#3#11+'Edit character range'); +{ cwriteat(34,19,#2#0+#3#14+' L: '+#3#11+'Load new color filter');} + cwriteat(34,19,#2#0+#3#14+' S: '+#3#11+'Save color filter'); + cwriteat(34,20,#2#0+#3#14+' Q: '+#3#11+'Quit & Save'); + + changed:=FALSE; done:=FALSE; + feedback:=#0; + while (not done) do begin + if (feedback<>#0) then begin + c:=feedback; + feedback:=#0; + end else + c:=readkey; + case upcase(c) of + '1'..'8': + begin + case c of + '1':begin editset:=set1; setname:='Upper-case letters'; end; + '2':begin editset:=set2; setname:='Lower-case letters'; end; + '3':begin editset:=set3; setname:='Number chrs'; end; + '4':begin editset:=set4; setname:='Line-drawing chrs'; end; + '5':begin editset:=set5; setname:='Graphic chrs'; end; + '6':begin editset:=set6; setname:='Other chrs'; end; + '7':begin editset:=set7; setname:='Bracket chrs'; end; + '8':begin editset:=set8; setname:='Special chrs'; end; + end; + + cwriteat(2,22,#3#14+'Editing pre-defined set #'+c); + cwriteat(4,23,#3#14+'"'+setname+'"'); + + docolortable(editset,1,1,feedback); + + gotoxy(1,22); clreol; gotoxy(1,23); clreol; + end; + 'A':addfilters; + 'C':begin + cwriteat(34,22,#3#14+'Select set starting character, and hit ;.'); + setc1:=#0; sx:=34; sy:=3; + getsetchr(setc1,sx,sy); + gotoxy(34,22); clreol; + if (setc1<>#0) then begin + cwriteat(34,22,#3#14+'Select set ending character, and hit ;.'); + setc2:=#0; + getsetchr(setc2,sx,sy); + gotoxy(34,22); clreol; + if (setc2<>#0) then begin + editset:=[]; + for c:=setc1 to setc2 do editset:=editset+[c]; + cwriteat(2,22,#3#14+'Editing user-defined set,'); + cwriteat(2,23,#3#14+'Chrs "'+setc1+'".."'+setc2+ + '" ('+cstr(ord(setc1))+'..'+cstr(ord(setc2))+')'); + + docolortable(editset,1,1,feedback); + + gotoxy(1,22); clreol; gotoxy(1,23); clreol; + end; + end; + end; + 'S':savecfilter; + 'Q':done:=TRUE; + end; + end; + + gotoxy(34,16); clreol; gotoxy(34,17); clreol; gotoxy(34,18); clreol; + gotoxy(34,19); clreol; gotoxy(34,20); clreol; + + if (changed) then begin + docwindow(askwindow,15,'Save? (Y/n)'); + repeat c:=upcase(readkey) until (c in ['Y','N',^M]); + removewindow1(askwindow); + changed:=(c<>'N'); + if (changed) then savecfilter; + end; + + exite(0); +end. diff --git a/common.pas b/common.pas new file mode 100644 index 0000000..0a5ccf4 --- /dev/null +++ b/common.pas @@ -0,0 +1,2965 @@ +{$A+,B+,D-,E+,F+,I+,L-,N-,O-,R-,S+,V-} +unit common; + +interface + +uses + crt,dos,printer, + myio,tmpcom,timejunk; + +{$I func.pas} +{$I rec25.pas} + +const strlen=160; + dsaves:integer=0; + BOXEDTITLE='`#['; + sepr2=#3#4+':'+#3#3; + +type f_initexecswap = function(p:pointer; s:string):boolean; + f_execwithswap = function(p,c:string):word; + p_shutdownexecswap = procedure; + +var initexecswap2:f_initexecswap; + execwithswap2:f_execwithswap; + shutdownexecswap2:p_shutdownexecswap; + +var uf:file of userrec; { USER.LST } + bf:file of boardrec; { BOARDS.DAT } + xf:file of protrec; { PROTOCOL.DAT } + ulf:file of ulrec; { UPLOADS.DAT } + ulff:file of ulfrec; { *.DIR } + sf:file of smalrec; { NAMES.LST } + smf:file of smr; { SHORTMSG.DAT } + verbf:file of verbrec; { VERBOSE.DAT } + mixf:file; { *.MIX } + brdf:file; { *.BRD } + + sysopf, { SYSOP.LOG } + sysopf1, { SLOGxxxx.LOG } + trapfile, { TRAP*.MSG } + cf:text; { CHAT*.MSG } + + systat:systatrec; { configuration information } + fstring:fstringrec; { string configuration } + modemr:modemrec; { modem configuration } + fidor:fidorec; { FidoNet information } + + thisuser:userrec; { user's account records } + macros:macrorec; { user's macros, if any } + zscanr:zscanrec; { user's zscan records } + + { BRD files } + msg_on:integer; { current message being read } + + { EVENTS } + events:array[0..maxevents] of ^eventrec; + numevents:integer; { # of events } + + { PROTOCOLS } + protocol:protrec; { protocol in memory } + numprotocols:integer; { # of protocols } + + { FILE BASES } + memuboard,tempuboard:ulrec; { uboard in memory, temporary uboard } + readuboard, { current uboard # in memory } + maxulb, { # of file bases } + fileboard:integer; { file base user is in } + + { MESSAGE BASES } + memboard:boardrec; { board in memory } + readboard, { current board # in memory } + numboards, { # of message bases } + board:integer; { message base user is in } + + { FILE/MESSAGE BASE COMPRESSION TABLES } + ccboards:array[0..1,1..maxboards] of byte; + ccuboards:array[0..1,0..maxuboards] of byte; + + spd:string[6]; { current modem speed, "KB" for local } + spdarq:boolean; { whether modem connected with ARQ } + +(*****************************************************************************) + + { message stuff } + mintabloaded:word; { minor table loaded } + mintaboffset:longint; { minor table file offset } + mintab:array[0..99] of msgindexrec; { minor table } + himsg:longint; { highest message number } + himintab:longint; { highest minor table number } + + + buf:string[255]; { macro buffer } + + sitedatetime:packdatetime; { last time site compiled/changed status } + + vercs:string; + vertypes:byte; { Alpha/Beta/etc, Registered, Node } + + chatr, { last chat reason } + cmdlist, { list of cmds on current menu } + irt, { reason for reply } + lastname, { author of last message displayed } + lastuname, { last name, whether anon or not } + licenseinfo, { licensing info, if present } + ll, { "last-line" string for word-wrapping } + start_dir:string; { directory BBS was executed from } + + tim, { time last keystroke entered } + timeon:datetimerec; { time user logged on } + + choptime, { time to chop off for system events } + extratime, { extra time - given by F7/F8, etc } + freetime, { free time } + oltime:real; + + answerbaud, { baud rate to answer the phone at } + exteventtime, { # minutes before external event } + maxheapspace, { max heap space available } + serialnumber:longint; { serial number, if present } + + chatt, { number chat attempts made by user } + etoday, { E-mail sent by user this call } + ftoday, { feedback sent by user this call } + lastprot, { last protocol # } + ldate, { last daynum() } + lil, { lines on screen since last pausescr() } + mread, { # public messages has read this call } + pap, { characters on this line so far } + ptoday, { posts made by user this call } + realdsl, { real DSL level of user } + realsl, { real SL level of user (for F9) } + usernum:integer; { user's user number } + + bread, { board loaded, or -1 for e-mail } + bwant:integer; + + chelplevel, { current help level } + curco, { current ANSI color } + elevel, { ERRORLEVEL to exit with } + tshuttlelogon:byte; { type of special Shuttle Logon command } + +const + allowabort:boolean=TRUE; { are aborts allowed? } + echo:boolean=TRUE; { is text being echoed? (FALSE=use echo chr)} + flistverb:boolean=TRUE; { list verbose descriptions? } + hangup:boolean=TRUE; { is user offline now? } + nofile:boolean=TRUE; { did last pfl() file NOT exist? } + onekcr:boolean=TRUE; { does ONEK prints upon exit? } + onekda:boolean=TRUE; { does ONEK display the choice? } + slogging:boolean=TRUE; { are we outputting to the SysOp log? } + sysopon:boolean=TRUE; { is SysOp logged onto the WFC menu? } + wantout:boolean=TRUE; { output text locally? } + wcolor:boolean=TRUE; { in chat: was last key pressed by SysOp? } + + badfpath:boolean=FALSE; { is the current DL path BAD? } + badufpath:boolean=FALSE; { is the current UL path BAD? } + badini:boolean=FALSE; { was last call to ini/inu value()=0, s<>"0"? } + bchanged:boolean=FALSE; { was BRD file changed? } + beepend:boolean=FALSE; { whether to beep after caller logs off } + bnp:boolean=FALSE; { was file base name printed yet? } + cfilteron:boolean=FALSE; { is the color filter on? } + cfo:boolean=FALSE; { is chat file open? } + ch:boolean=FALSE; { are we in chat mode? } + chatcall:boolean=FALSE; { is the chat call "noise" on? } + checkit:boolean=FALSE; { } + contlist:boolean=FALSE; { continuous message listing mode on? } + croff:boolean=FALSE; { are CRs turned off? } + ctrljoff:boolean=FALSE; { turn color to #1 after ^Js?? } + cwindowon:boolean=FALSE; { is SysOp window ON? } + doneafternext:boolean=FALSE; { offhook and exit after next logoff? } + doneday:boolean=FALSE; { are we done now? ready to drop to DOS? } + dosansion:boolean=FALSE; { output chrs to DOS for ANSI codes?!!? } + dyny:boolean=FALSE; { does YN return Yes as default? } + enddayf:boolean=FALSE; { perfrom "endday" after logoff? } + fastlogon:boolean=FALSE; { if a FAST LOGON is requested } + hungup:boolean=FALSE; { did user drop carrier? } + incom:boolean=FALSE; { accepting input from com? } + inmsgfileopen:boolean=FALSE; { are we //U ULing a file into a message? } + inwfcmenu:boolean=FALSE; { are we in the WFC menu? } + lan:boolean=FALSE; { was last post/email anonymous/other? } + lastcommandgood:boolean=FALSE;{ was last command a REAL command? } + lastcommandovr:boolean=FALSE; { override PAUSE? (NO pause?) } + lmsg:boolean=FALSE; { } + macok:boolean=FALSE; { are macros OKay right now? } + mailread:boolean=FALSE; { did user delete some e-mail? } +(* minitermonly:boolean=FALSE; { load up MiniTerm ONLY? }*) + localioonly:boolean=FALSE; { local I/O ONLY? } + packbasesonly:boolean=FALSE; { pack message bases ONLY? } + mtcfilteron:boolean=FALSE; { Manhattan Transfer color-filter active } + mtcolors:boolean=FALSE; { Manhattan Transfer colors in use } + newmenutoload:boolean=FALSE; { menu command returns TRUE if new menu to load } + nightly:boolean=FALSE; { execute hard-coded nightly event? } + nofeed:boolean=FALSE; { } + nopfile:boolean=FALSE; { } + overlayinems:boolean=FALSE; { is overlay file in EMS memory? } + outcom:boolean=FALSE; { outputting to com? } + printingfile:boolean=FALSE; { are we printing a file? } + quitafterdone:boolean=FALSE; { quit after next user logs off? } + reading_a_msg:boolean=FALSE; { is user reading a message? } + readingmail:boolean=FALSE; { reading private mail? } + read_with_mci:boolean=FALSE; { read message with MCI? } + returna:boolean=FALSE; { return from MiniTerm and answer phone? } + shutupchatcall:boolean=FALSE; { was chat call "SHUT UP" for this call? } + smread:boolean=FALSE; { were "small messages" read? (delete them) } + trapping:boolean=FALSE; { are we trapping users text? } + trm:boolean=FALSE; { is MiniTerm in use? } + useron:boolean=FALSE; { is there a user on right now? } + wantfilename:boolean=FALSE; { display message filename in scan? } + wascriterr:boolean=FALSE; { critical error during last call? } + wasguestuser:boolean=FALSE; { did a GUEST USER log on? } + wasnewuser:boolean=FALSE; { did a NEW USER log on? } + write_msg:boolean=FALSE; { is user writing a message? } + + telluserevent:byte=0; { has user been told about the up-coming event? } + exiterrors:byte=254; { ERRORLEVEL for Critical Error exit } + exitnormal:byte=255; { ERRORLEVEL for Normal exit } + + unlisted_filepoints=5; { file points for unlisted downloads } + +var + first_time:boolean; { first time loading a menu? } + menustack:array[1..8] of string[12]; { menu stack } + menustackptr:integer; { menu stack pointer } + last_menu, { last menu loaded } + curmenu:string; { current menu loaded } + menur:menurec; { menu information } + cmdr:array[1..50] of commandrec; { command information } + noc:integer; { # of commands on menu } + fqarea,mqarea:boolean; { file/message quick area changes } + + doit,doitt:boolean; + newdate:string[8]; { NewScan pointer date } + lrn:integer; { last record # for recno/nrecno } + lfn:string; { last filename for recno/nrecno } + + batchtime:real; { } + numbatchfiles:integer; { # files in DL batch queue } + batch:array[1..20] of record + fn:string[65]; + section:integer; + pts:integer; + blks:longint; + tt:real; + end; + + numubatchfiles:integer; { # files in UL batch queue } + ubatch:array[1..maxubatchfiles] of record + fn:string[12]; + section:integer; + description:string[65]; + vr:byte; + end; + ubatchv:array[1..maxubatchfiles] of ^verbrec; + hiubatchv:integer; + + +function lenn(s:string):integer; +function lennmci(s:string):integer; +procedure loaduboard(i:integer); +procedure loadboard(i:integer); +function smci(c:char):string; +procedure sprompt(s:string); +procedure tc(n:integer); +function mso:boolean; +function fso:boolean; +function cso:boolean; +function so:boolean; +function timer:real; +function fbaseac(b:byte):boolean; +function mbaseac(nb:integer):boolean; +procedure newcomptables; +procedure changefileboard(b:integer); +procedure changeboard(b:integer); +function freek(d:integer):longint; (* See disk space *) +function nma:integer; +function okansi:boolean; +function okavatar:boolean; +procedure cline(var s:string; dd:string); +function nsl:real; +function ageuser(bday:string):integer; (* returns age of user by birthdate *) +function allcaps(s:string):string; (* returns a COMPLETELY capitalized string *) +function caps(s:string):string; (* returns a capitalized string.. *) +procedure remove_port; +procedure iport; +{procedure initthething;} +function getwindysize(wind:integer):integer; +procedure commandline(s:string); +procedure sclearwindow; +procedure schangewindow(needcreate:boolean; newwind:integer); +function ccinkey1:char; +function cinkey1:char; +procedure gameport; +procedure sendcom1(c:char); +function recom1(var c:char):boolean; +procedure term_ready(ready_status:boolean); +procedure checkhangup; +function cinkey:char; +{procedure o(c:char);} +function intime(tim:real; tim1,tim2:integer):boolean; + (* check whether in time range *) +function sysop1:boolean; +function checkpw:boolean; +function sysop:boolean; +function stripcolor(o:string):string; +procedure sl1(s:string); +procedure sysoplog(s:string); +function tch(s:string):string; +function time:string; +function date:string; +function value(s:string):longint; +function cstr(i:longint):string; +function nam:string; +procedure shelldos(bat:boolean; cl:string; var rcode:integer); +procedure sysopshell(takeuser:boolean); +procedure readinzscan; +procedure savezscanr; +procedure redrawforansi; +function leapyear(yr:integer):boolean; +function days(mo,yr:integer):integer; +function daycount(mo,yr:integer):integer; +function daynum(dt:string):integer; +function dat:string; +procedure doeventstuff; +procedure getkey(var c:char); +procedure pr1(s:string); +procedure pr(s:string); +procedure sde; {* restore curco colors (DOS and tc) loc. after local *} +procedure sdc; +procedure stsc; +procedure setc(c:byte); +procedure cl(c:integer); +(*procedure promptc(c:char);*) +procedure dosansi(c:char); +procedure prompt(s:string); +function sqoutsp(s:string):string; +function exdrv(s:string):byte; +function mln(s:string; l:integer):string; +function mlnnomci(s:string; l:integer):string; +function mlnmci(s:string; l:integer):string; +function mrn(s:string; l:integer):string; +function mn(i,l:longint):string; +procedure pausescr; +procedure print(s:string); +procedure nl; +procedure prt(s:string); +procedure ynq(s:string); +procedure mpl(c:integer); +procedure tleft; +procedure prestrict(u:userrec); +procedure topscr; +procedure readinmacros; +procedure saveuf; +procedure loadurec(var u:userrec; i:integer); +procedure saveurec(u:userrec; i:integer); +function empty:boolean; +function inkey:char; +{procedure oc(c:char);} +procedure outkey(c:char); +function checkeventday(i:integer; t:real):boolean; +function checkpreeventtime(i:integer; t:real):boolean; +function checkeventtime(i:integer; t:real):boolean; +function checkevents(t:real):integer; +procedure dm(i:string; var c:char); +procedure cls; +procedure wait(b:boolean); +procedure swac(var u:userrec; r:uflags); +function tacch(c:char):uflags; +procedure acch(c:char; var u:userrec); +procedure sprint(s:string); +procedure lcmds(len,c:byte; c1,c2:string); +procedure autovalidate(var u:userrec; un:integer); +procedure rsm; +procedure inittrapfile; +procedure sysopstatus; +procedure chatfile(b:boolean); +function aonoff(b:boolean; s1,s2:string):string; +function onoff(b:boolean):string; +function syn(b:boolean):string; +procedure pyn(b:boolean); +function yn:boolean; +function pynq(s:string):boolean; +procedure inu(var i:integer); +procedure ini(var i:byte); +procedure inputwn1(var v:string; l:integer; flags:string; var changed:boolean); +procedure inputwn(var v:string; l:integer; var changed:boolean); +procedure inputwnwc(var v:string; l:integer; var changed:boolean); +procedure inputmain(var s:string; ml:integer; flags:string); +procedure inputwc(var s:string; ml:integer); +procedure input(var s:string; ml:integer); +procedure inputl(var s:string; ml:integer); +procedure inputcaps(var s:string; ml:integer); +procedure onek(var c:char; ch:string); +procedure local_input1(var i:string; ml:integer; tf:boolean); +procedure local_input(var i:string; ml:integer); +procedure local_inputl(var i:string; ml:integer); +procedure local_onek(var c:char; ch:string); +function centre(s:string):string; +procedure wkey(var abort,next:boolean); +function ctim(rl:real):string; +function tlef:string; +procedure printa1(s:string; var abort,next:boolean); +procedure printacr(s:string; var abort,next:boolean); +function longtim(dt:datetimerec):string; +function dt2r(dt:datetimerec):real; +procedure r2dt(r:real; var dt:datetimerec); +procedure timediff(var dt:datetimerec; dt1,dt2:datetimerec); +procedure getdatetime(var dt:datetimerec); +function cstrl(li:longint):string; +function cstrr(rl:real; base:integer):string; +procedure savesystat; (* save systat *) +procedure pfl(fn:string; var abort,next:boolean; cr:boolean); +procedure printfile(fn:string); +function exist(fn:string):boolean; +procedure printf(fn:string); +procedure mmkey(var s:string); + +procedure com_flush_rx; +function com_carrier:boolean; +function com_rx_empty:boolean; +procedure com_set_speed(speed:word); + +procedure chat; +procedure skey(c:char); +procedure showudstats; +procedure skey1(c:char); +function verline(i:integer):string; +function aacs1(u:userrec; un:integer; s:string):boolean; +function aacs(s:string):boolean; + +procedure DisableInterrupts; +procedure EnableInterrupts; + +implementation + +uses common1, common2, common3; + +(*****************************************************************************\ + ** + ** These routines have been placed in the overlay to decrease the + ** in-memory size of the BBS. Routines that are used frequently, and are + ** HIGHLY related to the overall speed of the BBS, have been kept out + ** of the overlay file, and remain in memory at all times. + ** +\*****************************************************************************) +function checkpw:boolean; begin checkpw:=common1.checkpw; end; +procedure newcomptables; begin common1.newcomptables; end; +procedure cline(var s:string; dd:string); begin common1.cline(s,dd); end; +procedure pausescr; begin common1.pausescr; end; +procedure wait(b:boolean); begin common1.wait(b); end; +(*procedure fix_window; begin common1.fix_window; end;*) +procedure inittrapfile; begin common1.inittrapfile; end; +procedure chatfile(b:boolean); begin common1.chatfile(b); end; +procedure local_input1(var i:string; ml:integer; tf:boolean); + begin common1.local_input1(i,ml,tf); end; +procedure local_input(var i:string; ml:integer); + begin common1.local_input(i,ml); end; +procedure local_inputl(var i:string; ml:integer); + begin common1.local_inputl(i,ml); end; +procedure local_onek(var c:char; ch:string); + begin common1.local_onek(c,ch); end; +function chinkey:char; begin chinkey:=common1.chinkey; end; +procedure inli1(var s:string); begin common1.inli1(s); end; +procedure chat; begin common1.chat; end; +procedure sysopshell(takeuser:boolean); + begin common1.sysopshell(takeuser); end; +procedure globat(i:integer); begin common1.globat(i); end; +procedure exiterrorlevel; begin common1.exiterrorlevel; end; +procedure showsysfunc; begin common1.showsysfunc; end; +procedure readinzscan; begin common1.readinzscan; end; +procedure savezscanr; begin common1.savezscanr; end; +procedure redrawforansi; begin common1.redrawforansi; end; + +procedure showudstats; begin common2.showudstats; end; +procedure skey1(c:char); begin common2.skey1(c); end; +procedure savesystat; begin common2.savesystat; end; +procedure remove_port; begin common2.remove_port; end; +procedure iport; begin common2.iport; end; +{procedure initthething; begin common2.initthething; end;} +procedure gameport; begin common2.gameport; end; +procedure sendcom1(c:char); begin common2.sendcom1(c); end; +function recom1(var c:char):boolean; begin recom1:=common2.recom1(c); end; +procedure term_ready(ready_status:boolean); begin common2.term_ready(ready_status); end; +function getwindysize(wind:integer):integer; begin getwindysize:=common2.getwindysize(wind); end; +procedure commandline(s:string); begin common2.commandline(s); end; +procedure sclearwindow; begin common2.sclearwindow; end; +procedure schangewindow(needcreate:boolean; newwind:integer); + begin common2.schangewindow(needcreate,newwind); end; +procedure topscr; begin common2.topscr; end; +procedure tleft; begin common2.tleft; end; +procedure readinmacros; begin common2.readinmacros; end; +procedure saveuf; begin common2.saveuf; end; + +procedure inu(var i:integer); begin common3.inu(i); end; +procedure ini(var i:byte); begin common3.ini(i); end; +procedure inputwn1(var v:string; l:integer; flags:string; var changed:boolean); + begin common3.inputwn1(v,l,flags,changed); end; +procedure inputwn(var v:string; l:integer; var changed:boolean); + begin common3.inputwn(v,l,changed); end; +procedure inputwnwc(var v:string; l:integer; var changed:boolean); + begin common3.inputwnwc(v,l,changed); end; +procedure inputmain(var s:string; ml:integer; flags:string); + begin common3.inputmain(s,ml,flags); end; +procedure inputwc(var s:string; ml:integer); begin common3.inputwc(s,ml); end; +procedure input(var s:string; ml:integer); begin common3.input(s,ml); end; +procedure inputl(var s:string; ml:integer); begin common3.inputl(s,ml); end; +procedure inputcaps(var s:string; ml:integer); + begin common3.inputcaps(s,ml); end; +procedure mmkey(var s:string); begin common3.mmkey(s); end; + +procedure com_flush_rx; begin tmpcom.com_flush_rx; end; +function com_carrier:boolean; begin com_carrier:=tmpcom.com_carrier; end; +function com_rx_empty:boolean; begin com_rx_empty:=tmpcom.com_rx_empty; end; +procedure com_set_speed(speed:word); begin tmpcom.com_set_speed(speed); end; +(*****************************************************************************) + +var cfilter:cfilterrec; + cfiltertype,cfilternum,cfiltercount:integer; + +procedure shelldos(bat:boolean; cl:string; var rcode:integer); +var t:text; + s:string; + i,speed:integer; + emsswap:boolean; +begin + nosound; + if (bat) then begin + assign(t,'tgtempx.bat'); rewrite(t); + writeln(t,cl); + close(t); + cl:='tgtempx.bat'; + end; + if (cl<>'') then cl:='/c '+cl; { if '', just a local shell to DOS } + + s:=^M^J+#27+'[0m'; + for i:=1 to length(s) do dosansi(s[i]); + + remove_port; + + emsswap:=FALSE; + if (systat.swapshell) then + if (initexecswap2(heapptr,systat.swappath+'TGSWAP.$$$')) then + emsswap:=TRUE; + swapvectors; + if (not emsswap) then exec(getenv('COMSPEC'),cl) else begin + textcolor(7); writeln('Swapping...'); + if (execwithswap2(getenv('COMSPEC'),cl)<>0) then begin + writeln('Cannot swap, performing normal execution'); + exec(getenv('COMSPEC'),cl); + end else shutdownexecswap2; + end; + swapvectors; + + rcode:=lo(dosexitcode); + if (bat) then begin + assign(t,'tgtempx.bat'); + {$I-} erase(t); {$I+} + if (ioresult<>0) then ; + end; + if (spd='KB') then speed:=modemr.waitbaud else speed:=value(spd); + iport; { installint(modemr.comport);} + openport(modemr.comport,speed,'N',8,1); +end; + +procedure sysopstatus; +begin + if (sysop) then begin + nl; + printf('SYSOPIN'); + if (nofile) then sprint(fstring.sysopin); + end else begin + nl; + printf('SYSOPOUT'); + if (nofile) then sprint(fstring.sysopout); + end; +end; + + +procedure DisableInterrupts; +begin +{rcg11172000 not needed under Linux.} +(* + inline($FA); {cli} +*) +end; + +procedure EnableInterrupts; +begin +{rcg11172000 not needed under Linux.} +(* + inline($FB); {sti} +*) +end; + +procedure autovalidate(var u:userrec; un:integer); +var settings:set of uflags; + b:boolean; +begin + settings:=[rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,rpost,remail, + rvoting,rmsg,fnodlratio,fnopostratio,fnofilepts,fnodeletion]; + with u do begin + if (un=usernum) then begin + realsl:=sl; realdsl:=dsl; + newcomptables; + end; + sl:=systat.autosl; dsl:=systat.autodsl; + ac:=ac-settings; + ac:=ac+(systat.autoac*settings); + (* do NOT modify user's personal settings, such as ANSI, color, etc.. *) + ar:=systat.autoar; + tltoday:=systat.timeallow[sl]; + end; +end; + +procedure rsm; +var x:smr; + i:integer; +begin + {$I-} reset(smf); {$I+} + if ioresult=0 then begin + i:=0; cl(1); + repeat + if (i<=filesize(smf)-1) then begin seek(smf,i); read(smf,x); + end; + while (iusernum) do begin + inc(i); + seek(smf,i); read(smf,x); + end; + if (x.destin=usernum) and (i<=filesize(smf)-1) then begin + print(x.msg); + seek(smf,i); x.destin:=-1; write(smf,x); + smread:=TRUE; + end; + inc(i); + until (i>filesize(smf)-1) or hangup; + close(smf); + cl(1); + end; +end; + +function lenn(s:string):integer; +var i,len:integer; +begin + len:=length(s); i:=1; + while (i<=length(s)) do begin + if (s[i] in [#3,'^']) then + if (ilength(s)) then lastco:=TRUE; + '@':if (not lastmci) and (i<>length(s)) then lastmci:=TRUE; + end + else begin + if (lastco) then + if s[i] in [#0..#9,'0'..'9'] then begin + dec(len,2); + lastco:=FALSE; + end; + if (lastmci) then begin + dec(len,2); + inc(len,lennmci(smci(s[i]))); + lastmci:=FALSE; + end; + end; + lennmci:=len; +end; + +procedure loaduboard(i:integer); +var ulfo:boolean; +begin + if (readuboard<>i) then begin + ulfo:=(filerec(ulf).mode<>fmclosed); + if (not ulfo) then reset(ulf); + if ((i>=0) and (i<=filesize(ulf)-1)) then begin + seek(ulf,i); + read(ulf,memuboard); + end else + memuboard:=tempuboard; + readuboard:=i; + if (not ulfo) then close(ulf); + end; +end; + +procedure loadboard(i:integer); +var bfo:boolean; +begin + if (readboard<>i) then begin + bfo:=(filerec(bf).mode<>fmclosed); + if (not bfo) then reset(bf); + if ((i-1<0) or (i-1>filesize(bf)-1)) then i:=1; + seek(bf,i-1); read(bf,memboard); + readboard:=i; + if (not bfo) then close(bf); + end; +end; + +procedure lcmds(len,c:byte; c1,c2:string); +var s:string; +begin + s:=copy(c1,2,lenn(c1)-1); + if (c2<>'') then s:=mln(s,len-1); + sprompt(#3#1+'('+#3+chr(c)+c1[1]+#3#1+')'+s); + if (c2<>'') then sprompt(#3#1+'('+#3+chr(c)+c2[1]+#3#1+')'+copy(c2,2,lenn(c2)-1)); + nl; +end; + +procedure tc(n:integer); +begin + textcolor(n); +end; + +function mso:boolean; +var i:byte; + b:boolean; +begin + b:=FALSE; + for i:=1 to 5 do + if (board=thisuser.boardsysop[i]) then b:=TRUE; + mso:=((cso) or (aacs(systat.msop)) or (b)); +end; + +function fso:boolean; +begin + fso:=((cso) or (aacs(systat.fsop))); +end; + +function cso:boolean; +begin + cso:=((so) or (aacs(systat.csop))); +end; + +function so:boolean; +begin + so:=(aacs(systat.sop)); +end; + +function timer:real; +var r:registers; + h,m,s,t:real; +begin + r.ax:=44*256; + msdos(dos.registers(r)); + h:=(r.cx div 256); m:=(r.cx mod 256); s:=(r.dx div 256); t:=(r.dx mod 256); + timer:=h*3600+m*60+s+t/100; +end; + +function fbaseac(b:byte):boolean; +begin + fbaseac:=FALSE; + if ((b<0) or (b>maxulb)) then exit; + loaduboard(b); + fbaseac:=aacs(memuboard.acs); +end; + +function mbaseac(nb:integer):boolean; +begin + mbaseac:=FALSE; + if ((nb<1) or (nb>numboards)) then exit; + loadboard(nb); + mbaseac:=aacs(memboard.acs); +end; + +procedure changefileboard(b:integer); +var s:string[20]; + go:boolean; +begin + go:=FALSE; + if (b>=0) and (b<=maxulb) then + if (fbaseac(b)) then { fbaseac loads memuboard itself ... } + if (memuboard.password='') then go:=TRUE + else begin + nl; sprint('File base '+cstr(ccuboards[1][b])+': '+ + #3#5+memuboard.name); + prt('Password? '); mpl(20); input(s,20); + if (s=memuboard.password) then go:=TRUE else print('Wrong.'); + end; + if (go) then begin fileboard:=b; thisuser.lastfil:=fileboard; end; +end; + +procedure changeboard(b:integer); +var s:string[20]; + go:boolean; +begin + go:=FALSE; + if (b>=1) and (b<=numboards) then + if (mbaseac(b)) then { mbaseac loads memboard itself ... } + if (memboard.password='') then go:=TRUE + else begin + nl; sprint('Message base '+cstr(ccboards[1][b])+': '+ + #3#5+memboard.name); + prt('Enter thy Password? '); mpl(20); input(s,20); + if (s=memboard.password) then go:=TRUE else print('Wrong.'); + end; + if (go) then begin board:=b; thisuser.lastmsg:=board; end; +end; + +function freek(d:integer):longint; +var lng:longint; +begin + lng:=diskfree(d); + freek:=lng div 1024; +end; + +function nma:integer; +begin + nma:=thisuser.tltoday; +end; + +function okansi:boolean; +begin + okansi:=((ansi in thisuser.ac) or (avatar in thisuser.ac)); +end; + +function okavatar:boolean; +begin + okavatar:=((avatar in thisuser.ac) and (not mtcolors)); +end; + +function nsl:real; +var ddt,dt:datetimerec; + beenon:real; +begin + if ((useron) or (not inwfcmenu)) then begin + getdatetime(dt); + timediff(ddt,timeon,dt); + beenon:=dt2r(ddt); + nsl:=((nma*60.0+extratime+freetime)-(beenon+choptime)); + end else + nsl:=3600.0 +end; + +procedure checkhangup; +begin + if (not com_carrier) then + if ((outcom) and (not hangup)) then begin + hangup:=TRUE; hungup:=TRUE; + end; +end; + +function waitackfile(s:string):boolean; +var rl:real; +begin + pr1(^T+'f'+s+';'); + rl:=timer; + waitackfile:=TRUE; + repeat + if (not com_rx_empty) then + case com_rx of + #6:exit; { ACK } + #21:begin waitackfile:=FALSE; exit; end; { NAK } + end; + until (timer-rl>10.0); + waitackfile:=FALSE; +end; + +procedure sendfilep(s:string); +var f:file of char; + ps:string[67]; + ns:string[8]; + es:string[4]; + c:char; +begin + assign(f,s); + {$I-} reset(f); {$I+} + if (ioresult<>0) then begin + pr(''); + pr('"'+s+'": File not found.'); + pr(''); + end else begin + fsplit(s,ps,ns,es); + if (waitackfile(ns+es)) then begin + while (not eof(f)) do begin read(f,c); com_tx(c); end; + pr1(^Z^Z^Z); + end; + close(f); + end; +end; + +procedure handlempcode(var ccc:char); +var tf:file of tfilerec; + temptfilebase:tfilerec; + tempboard:boardrec; + s:string; + i,j:integer; + mc:array[1..6] of char; + bfo,ulfo:boolean; +begin + if (not mpcoder) then exit; + ccc:=#0; + for i:=1 to 6 do mc[i]:=chr(mpcode[i]); + case chr(mpcode[1]) of + 'r':begin + if (mc[2]+mc[3]='mt') then mtcolors:=(mc[4]='1'); + end; + '*':begin + if (mc[2]+mc[3]='li') then + case mc[4] of + 'b':begin + pr(''); + bfo:=(filerec(bf).mode<>fmclosed); + if (not bfo) then reset(bf); + i:=1; + with tempboard do + while (not eof(bf)) do begin + read(bf,tempboard); + s:=aonoff(aacs(acs),' ','*')+mn(i,3)+':'+ + mln(stripcolor(name),40)+':'+acs+'/'+password; + pr1(s+^M^J); + inc(i); + end; + pr(''); + if (not bfo) then close(bf); + end; + 'f':begin + pr(''); + ulfo:=(filerec(ulf).mode<>fmclosed); + if (not ulfo) then reset(ulf); + i:=1; + with tempuboard do + while (not eof(ulf)) do begin + read(ulf,tempuboard); + s:=aonoff(aacs(acs),' ','*')+mn(i,3)+':'+ + mln(stripcolor(name),40)+':'+acs+'/'+password; + pr1(s+^M^J); + inc(i); + end; + pr(''); + if (not ulfo) then close(ulf); + end; + 'r':sendfilep(start_dir+'\err.log'); + 't':begin + pr(''); + assign(tf,systat.gfilepath+'gfiles.dat'); + {$I-} reset(tf); {$I+} + i:=1; + read(tf,temptfilebase); j:=temptfilebase.gdaten; + with temptfilebase do + while ((not eof(tf)) and (i)');*) + mpcoder:=FALSE; +end; + +function ccinkey1:char; +var tar:array[1..20] of char; + rl:real; + tarc:integer; + c:char; +begin + if (recom1(c)) then begin + ccinkey1:=c; + if ((c=^A) and (not trm)) then begin + tarc:=1; tar[1]:=^B; + rl:=timer; + repeat + if (recom1(c)) then begin tar[tarc]:=c; inc(tarc); end; + until ((timer-rl>2.0) or (tarc>11) or (tar[1]<>^B)); +{ commandline('<<'+tar[3]+tar[4]+tar[5]+tar[6]+tar[7]+tar[8]+'>>');} + if (tarc>11) then begin + mpcoder:=(tar[1]+tar[2]+tar[9]+tar[10]+tar[11]=^B^A+#253+#254+#255); + if (mpcoder) then begin + for tarc:=1 to 6 do mpcode[tarc]:=ord(tar[tarc+2]); + handlempcode(c); ccinkey1:=#0; + end; + end; + end; + end else + ccinkey1:=#0; +end; + +function cinkey1:char; +var rl:real; + c:char; +begin + cinkey1:=ccinkey1; +(* if (recom1(c)) then begin + cinkey1:=c; + if ((c=^A) and (not trm)) then begin + rl:=timer; + repeat until ((timer-rl>2.0) or (mpcoder)); + if (mpcoder) then begin handlempcode(c); cinkey1:=#0; end; + end; + end else + cinkey1:=#0;*) +end; + +function cinkey:char; +begin + cinkey:=cinkey1; +end; + +procedure o(c:char); +begin + if ((outcom) and (not trm) and (c<>#1)) then sendcom1(c); +end; + +function intime(tim:real; tim1,tim2:integer):boolean; +(* "tim" is seconds (timer) time; tim1/tim2 are minutes time. *) +begin + intime:=TRUE; + while (tim>=24.0*60.0*60.0) do tim:=tim-24.0*60.0*60.0; + if (tim1<>tim2) then + if (tim2>tim1) then + if (tim<=tim1*60.0) or (tim>=tim2*60.0) then + intime:=FALSE + else + else + if (tim<=tim1*60.0) and (tim>=tim2*60.0) then + intime:=FALSE; +end; + +function sysop1:boolean; +{rcg11172000 ?!} +{ +var a:byte absolute $0000:$0417; +begin + if (a and 16)=0 then sysop1:=TRUE else sysop1:=FALSE; +end; +} +begin + writeln('STUB: common.pas; sysop1()...'); + sysop1 := FALSE; +end; + + +function sysop:boolean; +var s:boolean; +begin + s:=sysop1; +{ if (systat.lowtime=systat.hitime) then s:=FALSE;} + if (not intime(timer,systat.lowtime,systat.hitime)) then s:=FALSE; + if (rchat in thisuser.ac) then s:=FALSE; + sysop:=s; +end; + +procedure opensysopf; +begin + assign(sysopf,systat.trappath+'sysop.log'); + {$I-} append(sysopf); {$I+} + if (ioresult<>0) then begin + rewrite(sysopf); + append(sysopf); + end; +end; + +function stripcolor(o:string):string; +var s:string; + i:integer; + lc:boolean; +begin + s:=''; lc:=FALSE; + for i:=1 to length(o) do + if (lc) then lc:=FALSE + else if ((o[i]=#3) or (o[i]='^')) then lc:=TRUE else s:=s+o[i]; + stripcolor:=s; +end; + +procedure sl1(s:string); +begin + if (slogging) then begin + if (systat.stripclog) then s:=stripcolor(s); + if (systat.slogtype in [0,1]) then begin + if (textrec(sysopf).mode<>fmoutput) then opensysopf; + writeln(sysopf,s); + end; + if ((thisuser.slogseperate) and (textrec(sysopf1).mode=fmoutput)) then + writeln(sysopf1,s); + + if (systat.slogtype in [1,2]) then begin + if (not systat.stripclog) then s:=stripcolor(s); + writeln(lst,s); + end; + end; +end; + +procedure sysoplog(s:string); +begin + sl1(' '+s); +end; + +function tch(s:string):string; +begin + if (length(s)>2) then s:=copy(s,length(s)-1,2) else + if (length(s)=1) then s:='0'+s; + tch:=s; +end; + +function time:string; +var h,m,s:string[3]; + hh,mm,ss,ss100:word; +begin + gettime(hh,mm,ss,ss100); + str(hh,h); str(mm,m); str(ss,s); + time:=tch(h)+':'+tch(m)+':'+tch(s); +end; + +function date:string; +var r:registers; + y,m,d:string[3]; + yy,mm,dd,dow:word; +begin + getdate(yy,mm,dd,dow); + str(yy-1900,y); str(mm,m); str(dd,d); + date:=tch(m)+'/'+tch(d)+'/'+tch(y); +end; + +function value(s:string):longint; +var i:longint; + j:integer; +begin + val(s,i,j); + if (j<>0) then begin + s:=copy(s,1,j-1); + val(s,i,j) + end; + value:=i; + if (s='') then value:=0; +end; + +function cstr(i:longint):string; +var c:string[16]; +begin + str(i,c); + cstr:=c; +end; + +function nam:string; +begin + nam:=caps(thisuser.name)+' #'+cstr(usernum); +end; + +function ageuser(bday:string):integer; +var i:integer; +begin + i:=value(copy(date,7,2))-value(copy(bday,7,2)); + if (daynum(copy(bday,1,6)+copy(date,7,2))>daynum(date)) then dec(i); + ageuser:=i; +end; + +function allcaps(s:string):string; +var i:integer; +begin + for i:=1 to length(s) do s[i]:=upcase(s[i]); + allcaps:=s; +end; + +function caps(s:string):string; +var i:integer; +begin + for i:=1 to length(s) do + if (s[i] in ['A'..'Z']) then s[i]:=chr(ord(s[i])+32); + for i:=1 to length(s) do + if (not (s[i] in ['A'..'Z','a'..'z'])) then + if (s[i+1] in ['a'..'z']) then s[i+1]:=upcase(s[i+1]); + s[1]:=upcase(s[1]); + caps:=s; +end; + +function leapyear(yr:integer):boolean; +begin + leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0)); +end; + +function days(mo,yr:integer):integer; +var d:integer; +begin + d:=value(copy('312831303130313130313031',1+(mo-1)*2,2)); + if ((mo=2) and (leapyear(yr))) then inc(d); + days:=d; +end; + +function daycount(mo,yr:integer):integer; +var m,t:integer; +begin + t:=0; + for m:=1 to (mo-1) do t:=t+days(m,yr); + daycount:=t; +end; + +function daynum(dt:string):integer; +var d,m,y,t,c:integer; +begin + t:=0; + m:=value(copy(dt,1,2)); + d:=value(copy(dt,4,2)); + y:=value(copy(dt,7,2))+1900; + for c:=1985 to y-1 do + if (leapyear(c)) then inc(t,366) else inc(t,365); + t:=t+daycount(m,y)+(d-1); + daynum:=t; + if y<1985 then daynum:=0; +end; + +function dat:string; +const mon:array [1..12] of string[3] = + ('Jan','Feb','Mar','Apr','May','Jun', + 'Jul','Aug','Sep','Oct','Nov','Dec'); +var ap,x,y:string; i:integer; + year,month,day,dayofweek,hour,minute,second,sec100:word; +begin + getdate(year,month,day,dayofweek); + gettime(hour,minute,second,sec100); + + if (hour<12) then ap:='am' + else begin + ap:='pm'; + if (hour>12) then dec(hour,12); + end; + if (hour=0) then hour:=12; + + dat:=cstr(hour)+':'+tch(cstr(minute))+' '+ap+' '+ + copy('SunMonTueWedThuFriSat',dayofweek*3+1,3)+' '+ + mon[month]+' '+cstr(day)+', '+cstr(year); +(* 5:43 pm Fri Jul 28, 1989 *) + +(* + ap:=date; + y:=mon[value(copy(ap,1,2))]; + x:=x+' '+y+' '+copy(ap,4,2)+', '+cstr(1900+value(copy(ap,7,2))); + y:=time; i:=value(copy(y,1,2)); + if i>11 then ap:='pm' else ap:='am'; + if i>12 then i:=i-12; + if i=0 then i:=12; + dat:=cstr(i)+copy(y,3,3)+' '+ap+' '+x; +*) +end; + +procedure pr1(s:string); +var i:integer; +begin + for i:=1 to length(s) do sendcom1(s[i]); +end; + +procedure pr(s:string); +begin + pr1(s+#13); +end; + +procedure scc; {* make local textcolor( = curco *} +var f:integer; +begin + if (okansi) then begin + f:=curco and 7; + if (curco and 8)<>0 then inc(f,8); + if (curco and 128)<>0 then inc(f,16); + tc(f); + textbackground((curco shr 4) and 7); + end; +end; + +procedure sde; { restore curco colors (DOS and tc) loc. after local } +var c:byte; + b:boolean; +begin + if (okansi) then begin + c:=curco; curco:=255-curco; + b:=outcom; outcom:=FALSE; + setc(c); + outcom:=b; + end; +end; + +procedure sdc; { restore curco colors (DOS and tc) loc/rem after loc/rem } +var c:byte; +begin + if (okansi) then begin + c:=curco; curco:=255-curco; + setc(c); + end; +end; + +procedure stsc; +begin + tc(11); textbackground(0); +end; + +function getc(c:byte):string; +const xclr:array[0..7] of char=('0','4','2','6','1','5','3','7'); +var s:string; + b:boolean; + + procedure adto(ss:string); + begin + if (s[length(s)]<>';') and (s[length(s)]<>'[') then s:=s+';'; + s:=s+ss; b:=TRUE; + end; + +begin + b:=FALSE; + if ((curco and (not c)) and $88)<>0 then begin + s:=#27+'[0'; + curco:=$07; + end else + s:=#27+'['; + if (c and 7<>curco and 7) then adto('3'+xclr[c and 7]); + if (c and $70<>curco and $70) then adto('4'+xclr[(c shr 4) and 7]); + if (c and 128<>0) then adto('5'); + if (c and 8<>0) then adto('1'); + if (not b) then adto('3'+xclr[c and 7]); + s:=s+'m'; + getc:=s; +end; + +procedure omtcolor(c:byte); +const color:array[0..15] of byte=($00,$04,$02,$06,$01,$05,$03,$07, + $08,$0C,$0A,$0E,$09,$0D,$0B,$0F); +var c1:byte; +begin + if (mtcolors) then begin + if (c and $70=0) then pr1(^T+chr(c or $70)) else pr1(^T+'C'+chr(c)); + end else begin + if (thisuser.avadjust=2) then begin + c1:=color[c and $0F]+(color[(c and $70) shr 4] shl 4); + if (c and $80<>0) then c1:=c1 or $80; + pr1(^V^A+chr(c1)); + end else pr1(^V^A+chr(c and $7F)); + if (c and $80<>0) then pr1(^V^B); + end; +end; + +procedure setc(c:byte); +var s:string; + i:integer; +begin + if ((c<>curco) or (dosansion)) then begin + s:=getc(c); curco:=c; + if (okansi) then begin + if (outcom) then + if ((okavatar) or (mtcolors)) then omtcolor(c) else pr1(s); + if (wantout) then begin + textattr:=c; + if (dosansion) then begin + s:=#27+'[0;'+copy(s,3,length(s)-2); + for i:=1 to length(s) do dosansi(s[i]); + end; + end; + end; + scc; + end; +end; + +procedure cl(c:integer); +begin + if (c in [0..9]) then + if (okansi) then + setc(thisuser.cols[(color in thisuser.ac)][c]); +end; + +function sqoutsp(s:string):string; +begin + while (pos(' ',s)>0) do delete(s,pos(' ',s),1); + sqoutsp:=s; +end; + +function exdrv(s:string):byte; +begin + s:=fexpand(s); + exdrv:=ord(s[1])-64; +end; + +function mlnnomci(s:string; l:integer):string; +begin + while (length(s)l) then + repeat s:=copy(s,1,length(s)-1) until (length(s)=l) or (length(s)=0); + mlnnomci:=s; +end; + +function mlnmci(s:string; l:integer):string; +begin + while (lennmci(s)l) then + repeat s:=copy(s,1,length(s)-1) until (lennmci(s)=l) or (length(s)=0); + mlnmci:=s; +end; + +function mln(s:string; l:integer):string; +begin + while (lenn(s)l) then + repeat s:=copy(s,1,length(s)-1) until (lenn(s)=l) or (length(s)=0); + mln:=s; +end; + +function mrn(s:string; l:integer):string; +begin + while lenn(s)l then s:=copy(s,1,l); + mrn:=s; +end; + +function mn(i,l:longint):string; +begin + mn:=mln(cstr(i),l); +end; + +(* +procedure cjp; +begin + if ((not ch) and (not write_msg) and (not reading_a_msg)) then cl(1); +end; + +procedure docc(c:char); +begin + case c of + ^H:if (pap>0) then dec(pap); + ^L:begin + lil:=0; + clrscr; + end; + ^M:pap:=0; + ^J:begin + inc(lil); + if (lil>=thisuser.pagelen-1) then begin + lil:=0; + if (pause in thisuser.ac) then pausescr; + end; + end; + end; +end; + +procedure promptc(c:char); +begin + if (c=^J) then cjp; + if (wantout) then + if (((c<>^G) or (not incom)) and (not (c in [#1,^L]))) then +{ write(c);} + write(c); +{ if (trapping) then if (c<>^G) then write(trapfile,c);} + if (outcom) then sendcom1(c); + if ((c>=#32) and (c<=#255)) then inc(pap) else docc(c); +end; +*) + +procedure dosansi(c:char); +var r:registers; +begin + with r do begin + dx:=ord(c); ax:=$0200; + msdos(r); + end; +end; + +procedure lpromptc(c:char); +var ss:string; + bb:byte; +begin + if (c=^G) then exit; + case c of + ^H:if (pap>0) then dec(pap); + ^J:begin + if ((not ch) and (not write_msg) and (not reading_a_msg)) then + if ((not ctrljoff) and (not dosansion)) then begin + bb:=thisuser.cols[color in thisuser.ac][1]; + if ((outcom) and (okansi)) then + if ((okavatar) or (mtcolors)) then omtcolor(bb) else pr1(getc(bb)); + curco:=bb; textattr:=bb; + end else + lil:=0; + if (wantout) then write(^J); + inc(lil); + if (lil>=thisuser.pagelen-1) then begin + lil:=0; + if (pause in thisuser.ac) then pausescr; + end; + exit; + end; + ^L:lil:=0; + ^M:pap:=0; + ^[:dosansion:=TRUE; + end; + if (wantout) then if (not dosansion) then write(c) else dosansi(c); +end; + +procedure prompt(s:string); +var s1,s2:string; + i:integer; + bb:byte; +begin + checkhangup; + if (hangup) then exit; + if (outcom) then begin + s1:=s; + while (pos(^J,s1)<>0) do begin + i:=pos(^J,s1); + s2:=copy(s,1,i-1); s1:=copy(s1,i+1,length(s1)-i); + for i:=1 to length(s2) do sendcom1(s2[i]); + if ((not ch) and (not write_msg) and (not reading_a_msg)) then + if (not ctrljoff) then begin + bb:=thisuser.cols[color in thisuser.ac][1]; + if (okansi) then + if ((okavatar) or (mtcolors)) then omtcolor(bb) else pr1(getc(bb)); + curco:=bb; + end else + lil:=0; + sendcom1(^J); + end; + for i:=1 to length(s1) do sendcom1(s1[i]); + end; + for i:=1 to length(s) do lpromptc(s[i]); + if (trapping) then + if (copy(s,length(s)-1,2)=^M^J) then + writeln(trapfile,copy(s,1,length(s)-2)) + else + write(trapfile,s); +end; + +procedure print(s:string); +begin + prompt(s+^M^J); +end; + +procedure nl; +begin + prompt(^M^J); +end; + +procedure prt(s:string); +begin + cl(4); sprompt(s); cl(3); +end; + +procedure ynq(s:string); +begin + cl(7); sprompt(s); cl(3); +end; + +procedure mpl(c:integer); +var i,x:integer; +begin + if (okansi) then begin + cl(6); + x:=wherex; + if (outcom) then for i:=1 to c do sendcom1(' '); + if (wantout) then for i:=1 to c do write(' '); + gotoxy(x,wherey); + if (outcom) then begin + if (okavatar) then pr1(^Y+^H+chr(c)) else pr1(#27+'['+cstr(c)+'D'); + end; + end; + dec(pap,c); +end; + +function smci(c:char):string; +var s,dum:string; + i:integer; +begin + dum:=nam; + case upcase(c) of + 'A':s:=cstr(ccboards[1][board]); + 'B':begin + loadboard(board); + s:=#3#5+memboard.name; + end; + 'C':s:=cstr(ccuboards[1][fileboard]); + 'D':begin + loaduboard(fileboard); + s:=#3#5+memuboard.name; + if (fbnoratio in memuboard.fbstat) then s:=s+#3#5+' '; + end; + 'F':s:=copy(thisuser.realname,1,pos(' ',thisuser.realname)-1); + 'G':if (sysop) then begin + nl; + printf('SYSOPIN'); + if (nofile) then s:=(fstring.sysopin); + end else begin + nl; + printf('SYSOPOUT'); + if (nofile) then s:=fstring.sysopout; + end; + 'H':s:=copy(dum,1,pos('#',dum)-2); + 'K':begin + loaduboard(fileboard); + s:=cstrl(freek(exdrv(memuboard.ulpath))); + end; + 'L':begin + dum:=caps(thisuser.realname); + i:=length(dum); + while ((dum[i]<>' ') and (i>1)) do begin + s:=copy(dum,i,(length(dum)-i)+1); + dec(i); + end; + end; + 'M':s:=^M^J; + 'N':s:=dum; + 'P':s:=cstr(thisuser.filepoints); + 'R':s:=thisuser.realname; + 'T':s:=tlef; + 'U':s:=cstr(msg_on); + 'V':s:=cmdlist; + 'W':s:=cstr(himsg+1); + 'X':begin + if (cso) then i:=systat.csmaxlines else i:=systat.maxlines; + s:=cstr(i); + end; + 'Y':begin + loadboard(board); + s:=#3#5+memboard.name+#3#5+' #'+cstr(ccboards[1][board]); + end; + 'Z':s:=chatr; + else + s:='@'+c; + end; + smci:=s; +end; + +{rcg11172000 had to change this to get it compiling under Free Pascal...} +{function substone(src,old,new:string):string;} +function substone(src,old,_new:string):string; +var p:integer; +begin + if (old<>'') then begin + p:=pos(old,allcaps(src)); + if (p>0) then begin + insert(_new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substone:=src; +end; + +procedure sprompt(s:string); +var ss,sss:string; + i,p1,p2,x,z:integer; + c,mc:char; + xx,b:boolean; +begin + checkhangup; + if (hangup) then exit; + ss:=s; sss:=''; + b:=FALSE; + if (pos('@',ss)<>0) then begin + for c:='A' to 'Z' do + while (pos('@'+c,allcaps(ss))<>0) do begin + ss:=substone(ss,'@'+c,smci(c)); + b:=TRUE; + end; + while ((pos('@',ss)<>0) and (b)) do begin + for c:='A' to 'Z' do + while (pos('@'+c,allcaps(ss))<>0) do ss:=substone(ss,'@'+c,smci(c)); + for i:=1 to length(ss)-1 do + if ((ss[i]='@') and (not (ss[i+1] in ['A'..'Z']))) then + ss[i]:=#28; + if (ss[length(ss)]='@') then ss[length(ss)]:=#28; + end; + for i:=1 to length(ss) do + if (ss[i]=#28) then ss[i]:='@'; + end; + + if (trapping) then write(trapfile,ss); + if (not okansi) then + ss:=stripcolor(ss) + else + while (ss<>'') and ((pos(#3,ss)<>0) or (pos('^',ss)<>0)) do begin + p1:=pos(#3,ss); if (p1=0) then p1:=500; + p2:=pos('^',ss); if (p2=0) then p2:=500; + + if (p2500) then begin + mc:=ss[p1+1]; sss:=copy(ss,1,p1-1); + ss:=copy(ss,p1+2,length(ss)-(p1+1)); + end else begin + sss:=ss; ss:=''; + end; + + if (outcom) then + for i:=1 to length(sss) do sendcom1(sss[i]); + for i:=1 to length(sss) do lpromptc(sss[i]); + + if ((mc>=#0) and (mc<=#9)) then cl(ord(mc)) else + if ((mc>='0') and (mc<='9')) then cl(ord(mc)-48); + {**** ADD @E SUPPORT *} + + end; + if (outcom) then + for i:=1 to length(ss) do sendcom1(ss[i]); + for i:=1 to length(ss) do lpromptc(ss[i]); +end; + +procedure sprint(s:string); +begin + sprompt(s+'@M'); +end; + +procedure prestrict(u:userrec); +var r:uflags; +begin + for r:=rlogon to rmsg do + if (r in u.ac) then write(copy('LCVBA*PEKM',ord(r)+1,1)) else write('-'); + writeln; +end; + +function empty:boolean; +var e:boolean; +begin + e:=(not keypressed); + if ((incom) and (e)) then e:=(com_rx_empty); + if (hangup) then begin com_flush_rx; e:=TRUE; end; + empty:=e; +end; + +function inkey:char; +var c:char; +begin + c:=#0; inkey:=#0; + checkhangup; + if (keypressed) then begin + c:=readkey; + if ((c=#0) and (keypressed)) then begin + c:=readkey; + skey1(c); + if (c=#68) then c:=#1 else c:=#0; + if (buf<>'') then begin + c:=buf[1]; + buf:=copy(buf,2,length(buf)-1); + end; + end; + inkey:=c; + end else + if (incom) then inkey:=cinkey; +{ if ((async_buffer_head<>async_buffer_tail) and (incom)) then + inkey:=cinkey;} +end; + +procedure outtrap(c:char); +begin + if (c<>^G) then write(trapfile,c); +end; + +procedure docc2(c:char); +var i:integer; +begin + case c of + ^G:if (outcom) then for i:=1 to 4 do sendcom1(#0); + ^J:begin + if (wantout) then write(^J); + inc(pap); + end; + ^L:begin + if (wantout) then clrscr; + lil:=0; + end; + end; +end; + +procedure outkey(c:char); +begin + if (c=#29) then exit; + if (not echo) then + if ((systat.localsec) and (c in [#32..#255])) then c:=fstring.echoc; + if (c=#27) then dosansion:=TRUE; + if (not (c in [^J,^L])) then + if (not ((c=^G) and (incom))) then + if ((c<>#0) and (not nopfile) and (wantout)) then + if (not dosansion) then write(c) else dosansi(c); + if ((not echo) and (c in [#32..#255])) then c:=fstring.echoc; + if (outcom) then sendcom1(c); + if (c<#32) then docc2(c); +end; + +function checkeventday(i:integer; t:real):boolean; +var s:string; + year,month,day,dayofweek:word; + e:integer; +begin + checkeventday:=FALSE; + with events[i]^ do begin + getdate(year,month,day,dayofweek); + e:=0; + if (timer+t>=24.0*60.0*60.0) then begin + inc(dayofweek); e:=1; + if (dayofweek>6) then dayofweek:=0; + end; + if (monthly) then begin + if (value(copy(date,4,2))+e=execdays) then + checkeventday:=TRUE; + end else begin + if ((1 shl (6-dayofweek)) and execdays<>0) then + checkeventday:=TRUE; + end; + end; +end; + +function checkpreeventtime(i:integer; t:real):boolean; +begin + with events[i]^ do + if (busytime=0) then + checkpreeventtime:=FALSE + else + checkpreeventtime:=intime(timer+t,exectime-busytime,exectime); +end; + +function checkeventtime(i:integer; t:real):boolean; +begin + with events[i]^ do + if (duration=0) then + checkeventtime:=FALSE + else + checkeventtime:=intime(timer+t,exectime,exectime+duration); +end; + +function checkevents(t:real):integer; +var i:integer; +begin + for i:=0 to numevents do + with events[i]^ do + if (active) then + if (checkeventday(i,t)) then begin + checkevents:=i; + if (checkpreeventtime(i,t)) or (checkeventtime(i,t)) then begin + if (etype in ['D','E','P']) then exit; + if ((etype='A') and (not aacs(execdata)) and (useron)) then exit; + end; + end; + checkevents:=0; +end; + +procedure dm(i:string; var c:char); +begin + buf:=i; + if (buf<>'') then begin + c:=buf[1]; + buf:=copy(buf,2,length(buf)-1); + end; +end; + +procedure doeventstuff; +var s:string; + e,savpap:integer; + aaa:boolean; +begin + case telluserevent of + 0:begin + oltime:=timer; + e:=checkevents(systat.eventwarningtime); + if (e<>0) then begin + telluserevent:=1; + nl; + sysoplog('[> '+date+' '+time+' - Displayed "REVENT'+cstr(e)+'" in preparation for event #'+cstr(e)); + savpap:=pap; + aaa:=allowabort; allowabort:=FALSE; + printf('revent'+cstr(e)); + allowabort:=aaa; + if (nofile) then begin + nl; nl; + sprint(#3#8+^G'Warning: '+#3#5+'System event approaching.'^G); + sprint(#3#5+^G'System will be shut down in '+ + copy(ctim(systat.eventwarningtime),4,5)+' minutes.'^G); + nl; nl; + end; + pap:=savpap; + end else + if (checkevents(0)=0) then telluserevent:=0; + end; + 1:begin + oltime:=timer; + e:=checkevents(0); + if (e<>0) then begin + telluserevent:=2; + sysoplog('[> '+date+' '+time+' - Logged user off in preparation for '+ + 'event #'+cstr(e)); + nl; nl; sprint(#3#8+^G'Shutting down for system events'^G); nl; nl; + hangup:=TRUE; + end; + end; + end; +end; + +procedure getkey(var c:char); +var dt,ddt:datetimerec; + aphase,e:integer; + abort,next,b,tf,t1,bufalready:boolean; +begin + lil:=0; + if (buf<>'') then begin + c:=buf[1]; + buf:=copy(buf,2,length(buf)-1); + end else begin + if (not empty) then begin + if (ch) then c:=chinkey else c:=inkey; + end else begin + getdatetime(tim); + t1:=FALSE; tf:=FALSE; + c:=#0; + if (alert in thisuser.ac) then aphase:=1 else aphase:=0; + while ((c=#0) and (not hangup)) do begin + if (aphase<>0) then begin + case aphase of + 1:begin sound(1000); delay(35); end; + 2:begin sound(1500); delay(40); end; + 3:begin sound(1900); delay(45); end; + 4:begin sound(2300); delay(50); end; + 5:begin sound(3400); delay(55); end; + end; + aphase:=aphase mod 5+1; + end; + + if (ch) then c:=chinkey else c:=inkey; + getdatetime(dt); + timediff(ddt,tim,dt); + if (systat.timeout<>-1) and + (dt2r(ddt)>systat.timeout*60) and (c=#0) then begin + nl; nl; + printf('timedout'); + if (nofile) then + print('Time out has occurred. Log off time was at '+time+'.'); + nl; nl; + hangup:=TRUE; + sysoplog(#3#7+'!*!*! Time-out at '+time+' !*!*!'); + end; + if (systat.timeoutbell<>-1) and + (dt2r(ddt)>systat.timeoutbell*60) and (not tf) and (c=#0) then begin + tf:=TRUE; + outkey(^G); delay(100); outkey(^G); + end; + checkhangup; + end; + nosound; + end; + end; + if (checkit) then + if (ord(c) and 128>0) then checkit:=FALSE; + if (c<#32) then skey(c); +end; + +procedure cls; +begin + if (okansi) then begin + if (outcom) then begin + if (okavatar) then pr(^L) else pr(#27+'[2J'); + end; + if (wantout) then clrscr; + end else + outkey(^L); + if (trapping) then writeln(trapfile,^L); + cl(1); + lil:=0; +end; + +procedure swac(var u:userrec; r:uflags); +begin + if (r in u.ac) then + u.ac:=u.ac-[r] else u.ac:=u.ac+[r]; +end; + +function tacch(c:char):uflags; +begin + case c of + 'L':tacch:=rlogon; + 'C':tacch:=rchat; + 'V':tacch:=rvalidate; + 'B':tacch:=rbackspace; + 'A':tacch:=ramsg; + '*':tacch:=rpostan; + 'P':tacch:=rpost; + 'E':tacch:=remail; + 'K':tacch:=rvoting; + 'M':tacch:=rmsg; + '1':tacch:=fnodlratio; + '2':tacch:=fnopostratio; + '3':tacch:=fnofilepts; + '4':tacch:=fnodeletion; + end; +end; + +procedure acch(c:char; var u:userrec); +begin + swac(u,tacch(c)); +end; + +function aonoff(b:boolean; s1,s2:string):string; +begin + if (b) then aonoff:=s1 else aonoff:=s2; +end; + +function onoff(b:boolean):string; +begin + if (b) then onoff:='On ' else onoff:='Off'; +end; + +function syn(b:boolean):string; +begin + if (b) then syn:='Yes' else syn:='No '; +end; + +procedure pyn(b:boolean); +begin + print(syn(b)); +end; + +function yn:boolean; +var c:char; +begin + if (not hangup) then begin + cl(3); + repeat + getkey(c); + c:=upcase(c); + until (c in ['Y','N',^M,^N]) or (hangup); + if (dyny) and (c<>'N') then c:='Y'; + if (c='Y') then begin + print('Yes'); + yn:=TRUE; + end else begin + print('No'); + yn:=FALSE; + end; + if (hangup) then yn:=FALSE; + end; + dyny:=FALSE; +end; + +function pynq(s:string):boolean; +begin + ynq(s); + pynq:=yn; +end; + +procedure onek(var c:char; ch:string); +var s:string; +begin + repeat + if (not (onekey in thisuser.ac)) then begin + input(s,3); + if length(s)>=1 then c:=s[1] else + if (s='') and (pos(^M,ch)<>0) then c:=^M else + c:=' '; + end else begin + getkey(c); + c:=upcase(c); + end; + until (pos(c,ch)>0) or (hangup); + if (hangup) then c:=ch[1]; + if (onekey in thisuser.ac) then begin + if (onekda) then + if (c in [#13,#32..#255]) then begin + outkey(c); + if (trapping) then write(trapfile,c); + end; + if (onekcr) then nl; + end; + onekcr:=TRUE; + onekda:=TRUE; +end; + +function centre(s:string):string; +var i,j:integer; +begin + if (pap<>0) then nl; + if (s[1]=#2) then s:=copy(s,2,length(s)-1); + i:=length(s); j:=1; + while (j<=length(s)) do begin + if s[j]=#3 then begin + dec(i,2); + inc(j); + end; + inc(j); + end; + if i0) then begin + s:=s+cstrl(i)+' '+lab; + if (i<>1) then s:=s+'s'; + if (comma) then s:=s+', '; + end; + end; + +begin + s:=''; + with dt do begin + d:=day; + if (d>=7) then begin + ads(TRUE,d div 7,'week'); + d:=d mod 7; + end; + ads(TRUE,d,'day'); + ads(TRUE,hour,'hour'); + ads(TRUE,min,'minute'); + ads(FALSE,sec,'second'); + end; + if (s='') then s:='0 seconds'; + if (copy(s,length(s)-1,2)=', ') then s:=copy(s,1,length(s)-2); + longtim:=s; +end; + +function dt2r(dt:datetimerec):real; +begin + with dt do + dt2r:=day*86400.0+hour*3600.0+min*60.0+sec; +end; + +procedure r2dt(r:real; var dt:datetimerec); +begin + with dt do begin + day:=trunc(r/86400.0); r:=r-(day*86400.0); + hour:=trunc(r/3600.0); r:=r-(hour*3600.0); + min:=trunc(r/60.0); r:=r-(min*60.0); + sec:=trunc(r); + end; +end; + +procedure timediff(var dt:datetimerec; dt1,dt2:datetimerec); +begin + with dt do begin + day:=dt2.day-dt1.day; + hour:=dt2.hour-dt1.hour; + min:=dt2.min-dt1.min; + sec:=dt2.sec-dt1.sec; + + if (hour<0) then begin inc(hour,24); dec(day); end; + if (min<0) then begin inc(min,60); dec(hour); end; + if (sec<0) then begin inc(sec,60); dec(min); end; + end; +end; + +procedure getdatetime(var dt:datetimerec); +var w1,w2,w3,w4:word; +begin + gettime(w1,w2,w3,w4); + with dt do begin + day:=daynum(date); + hour:=w1; + min:=w2; + sec:=w3; + end; +end; + +function cstrl(li:longint):string; +var c:string; +begin + str(li,c); + cstrl:=c; +end; + +function cstrr(rl:real; base:integer):string; +var i:integer; + s:string; + r1,r2:real; +begin + if (rl<=0.0) then cstrr:='0' + else begin + r1:=ln(rl)/ln(1.0*base); + r2:=exp(ln(1.0*base)*(trunc(r1))); + s:=''; + while (r2>0.999) do begin + i:=trunc(rl/r2); + s:=s+copy('0123456789ABCDEF',i+1,1); + rl:=rl-i*r2; + r2:=r2/(1.0*base); + end; + cstrr:=s; + end; +end; + +procedure loadcfilter(s:string); +var cfilterf:file of cfilterrec; + os,ps,ns,es:string; + i:integer; +begin + if ((not printingfile) or (not okansi)) then exit; + os:=s; + if (copy(s,1,1)<>'*') then begin + if (not exist(s)) then begin + fsplit(s,ps,ns,es); + if (exist(systat.afilepath+ns+es)) then s:=systat.afilepath+ns+es + else + if (exist(systat.gfilepath+ns+es)) then s:=systat.gfilepath+ns+es; + end; + assign(cfilterf,s); + {$I-} reset(cfilterf); {$I+} + if (ioresult=0) then begin + {$I-} read(cfilterf,cfilter); {$I+} + if (ioresult=0) then begin + if (not mtcolors) then begin + cfilteron:=TRUE; + cfiltertype:=0; + end else begin + pr1(^T+'c='); + for i:=0 to 255 do sendcom1(chr(cfilter[i])); + pr1(';'); + mtcfilteron:=TRUE; cfilteron:=TRUE; + cfiltertype:=0; + end; + end; + close(cfilterf); + end else + sysoplog('Missing color filter: '+os); + end else begin + if (length(s)<3) then exit; + case upcase(s[2]) of + 'C':cfiltertype:=1; + 'R':cfiltertype:=2; + end; + s:=copy(s,3,length(s)-2); + cfilternum:=0; + while (pos(',',s)<>0) do begin + cfilter[cfilternum]:=value(s); inc(cfilternum); + s:=copy(s,pos(',',s)+1,length(s)-pos(',',s)); + end; + cfilter[cfilternum]:=value(s); inc(cfilternum); + cfilteron:=TRUE; cfiltercount:=0; + end; +end; + +procedure printa1(s:string; var abort,next:boolean); +var s1,s2,ss,sss,ssss,tcode,mcix,mcixx:string; + i,ls,p1,p2,p3:integer; + c,mc:char; + savcurco:byte; + isansi,iscolor,ismci,istcode,usetcodes:boolean; + + function nmci(s:string):string; + begin + nmci:=''; + case c of + '1':nmci:=thisuser.name; + '2':nmci:=thisuser.realname; + '3':nmci:=thisuser.ph; + '4':nmci:=thisuser.citystate; + '5':nmci:=thisuser.street; + '6':nmci:=thisuser.zipcode; + '!':if (printingfile) then allowabort:=FALSE; + '#':thisuser.ac:=thisuser.ac-[pause]; + end; + end; + + procedure domci(c:char); + begin + case c of + '7':cls; + '8':delay(800); + '9':pausescr; + end; + end; + + procedure dotcode(c:char; var s:string); + var s1,s2:string; + begin + case mc of + 'c':if (pos(';',s)<>0) then begin + s1:=copy(s,1,pos(';',s)-1); + delete(s,1,length(s1)+1); + loadcfilter(s1); + end; + 'C':begin + if (okansi) then setc(ord(s[1])); + delete(s,1,1); + end; + end; + end; + + procedure sends(s:string); + var i:word; + begin + i:=0; + while (icurco) then begin + if ((okavatar) or (mtcolors)) then omtcolor(bb) else pr1(getc(bb)); + curco:=bb; + end; + sendcom1(s[i]); + inc(i); + end; + curco:=savcurco; + end; + + procedure locs(s:string); + var i:integer; + begin + i:=0; + while (icurco) then begin textattr:=bb; curco:=bb; end; + lpromptc(s[i]); + inc(i); + end; + end; + + (* Forewarning to the faint of heart programmers: + The following section of code contains "goto" statements. + I'm VERY SORRY about this, and normally would NEVER EVER EVER + use such pathetic coding. ("Hey - where did this guy learn to + program, anyway - a BASIC class!??!?") + *) + + procedure handlecolors; + label goto1; + begin + goto1: { ack! } + mc:=ss[p1+1]; sss:=copy(ss,1,p1-1); + ss:=copy(ss,p1+2,length(ss)-(p1+1)); + + if (outcom) then sends(sss); + locs(sss); + + if ((mc>=#0) and (mc<=#9)) then cl(ord(mc)) else + if ((mc>='0') and (mc<='9')) then cl(ord(mc)-48); + + p1:=pos(#3,ss); + if (p1<>0) then goto goto1; + end; + + procedure handletcodes; + label goto1; { *ACK!* } + begin + goto1: + if ((p30)) then begin + istcode:=TRUE; + p2:=p3; + end else + istcode:=FALSE; + + mc:=ss[p2+1]; sss:=copy(ss,1,p2-1); + ss:=copy(ss,p2+2,length(ss)-(p2+1)); + + if (outcom) then sends(sss); + locs(sss); + + if (not istcode) then domci(mc) else + dotcode(mc,ss); + + p2:=pos('@',ss); p3:=pos(^T,ss); + if (p2+p3>0) then goto goto1; + end; + + procedure handletcodesc; + label goto1; { **ACK!!!*!*!***** } + begin + goto1: + if (p2<>500) then + if (pos(ss[p2+1],mcixx)=0) then p2:=500; + + iscolor:=TRUE; istcode:=FALSE; + if ((p2=#0) and (mc<=#9)) then cl(ord(mc)) else + if ((mc>='0') and (mc<='9')) then cl(ord(mc)-48); + end else + if (not istcode) then domci(mc) else + dotcode(mc,ss); + + p1:=pos(#3,ss); if (p1=0) then p1:=500; + p2:=pos('@',ss); if (p2=0) then p2:=500; + p3:=pos(^T,ss); if (p3=0) then p3:=500; + if (p1+p2+p3<1500) then goto goto1; + end; + +begin + tcode:=''; ss:=''; + if (abort) then exit; + doit:=TRUE; isansi:=FALSE; + if (pos(^[,s)<>0) then begin + lil:=0; + isansi:=TRUE; + end else + if (s[1]='&') then begin + if (thisuser.sl0) then + for i:=1 to 8 do begin + c:=mcix[i]; + while (pos('@'+c,ss)<>0) do ss:=substone(ss,'@'+c,nmci(c)); + end; + while (pos(#29,ss)<>0) do delete(ss,pos(#29,ss),1); + if (not okansi) then ss:=stripcolor(ss); + if (trapping) then write(trapfile,ss); + + {if ((isansi) and (okavatar)) then ss:=avatar(ss);} + if (not cfilteron) then begin + p1:=pos(#3,ss); if (p1=0) then p1:=500; + p2:=pos('@',ss); if (p2=0) then p2:=500; + p3:=pos(^T,ss); if (p3=0) then p3:=500; + if (isansi) then begin + p1:=500; p2:=500; p3:=500; + end; + + if (((reading_a_msg) and (not read_with_mci)) and (p2+p3<>1000)) then + begin p2:=500; p3:=500; end; + + if ((p2=500) and (p3=500)) then begin + if (p1<>500) then handlecolors; + end else + if (p1=500) then handletcodes else handletcodesc; + if (outcom) then sends(ss); + locs(ss); + end else begin + if (outcom) then if (mtcfilteron) then sends(ss) else sendscfilter(ss); + locscfilter(ss); + if (cfiltertype=0) then + if ((cfilter[32] and 112)<>0) then begin + setc(cfilter[32]); + if (okavatar) then pr1(^V+^G) else pr1(^['[K'); + clreol; + end; + end; + wkey(abort,next); + +(* + findtcode:=FALSE; tcode:=''; ss:=''; + if (abort) then exit; + doit:=TRUE; + if (s[1]='&') then begin + if (thisuser.sl'') and (trapping)) then write(trapfile,ss); + ss:=''; + domci(s[i+1]); + end; + if (not didmci) then begin + case s[i] of + #3:if (i#3) then s:=copy(s,1,length(s)-1); + + okdoit:=TRUE; abort:=FALSE; nopfile:=FALSE; + turnoff:=(s[length(s)]=#29); + + if (copy(s,1,1)='&') then begin + if (thisuser.sl0) then begin + printa1(s,abort,next); + if ((not turnoff) and (not croff)) then begin + nl; + if (trapping) then writeln(trapfile); + end; + croff:=FALSE; + exit; + end else + if (s[1]=#2) then begin + printa1(centre(s),abort,next); + if (not turnoff) then nl; + croff:=FALSE; exit; + end else + if (length(s)>=3) and (copy(s,1,3)=BOXEDTITLE) then begin + doboxedtitle(copy(s,4,length(s)-3)); + croff:=FALSE; exit; + end else begin +{ wkey(abort,next);} + printa1(s,abort,next); + if (abort) then begin curco:=255-curco; cl(1); end; + if ((not nofeed) and (doit) and (not croff) and (not turnoff)) then + if (not abort) then nl; + doit:=TRUE; + end; + croff:=FALSE; +end; + +procedure pfl(fn:string; var abort,next:boolean; cr:boolean); +var fil:text; + ofn:string; + ls:string[255]; + ps:integer; + c:char; + oldpause,oaa:boolean; +begin + cfilteron:=FALSE; cfiltertype:=0; cfilternum:=0; cfiltercount:=0; + printingfile:=TRUE; + oaa:=allowabort; + allowabort:=TRUE; + abort:=FALSE; next:=FALSE; +{ if (not allowabort) then begin + abort:=FALSE; next:=FALSE; + end;} + oldpause:=(pause in thisuser.ac); + nofile:=FALSE; + if (not hangup) then begin + assign(fil,sqoutsp(fn)); + {$I-} reset(fil); {$I+} + if (ioresult<>0) then nofile:=TRUE + else begin + abort:=FALSE; + while ((not eof(fil)) and (not nofile) and + (not abort) and (not hangup)) do begin + ps:=0; + repeat + inc(ps); + read(fil,ls[ps]); + until ((ls[ps]=^M) or (ps=255) or (eof(fil)) or (hangup)); + ls[0]:=chr(ps); + if (ls[ps]=^M) then begin + if (not eof(fil)) then read(fil,c); + ls[0]:=chr(ps-1); + end else + croff:=TRUE; + if (pos(^[,ls)<>0) then ctrljoff:=TRUE; + printacr(ls,abort,next); + end; + close(fil); +{ if (abort) then nl;} + end; + end; + if (oldpause) then thisuser.ac:=thisuser.ac+[pause]; + allowabort:=oaa; + if (mtcfilteron) then begin pr1(^T'c-'); mtcfilteron:=FALSE; end; + cfilteron:=FALSE; printingfile:=FALSE; ctrljoff:=FALSE; + curco:=255-curco; cl(1); + redrawforansi; +end; + +function exist(fn:string):boolean; +var srec:searchrec; +begin + findfirst(sqoutsp(fn),anyfile,srec); + exist:=(doserror=0); +end; + +procedure printfile(fn:string); +var s:string; + year,month,day,dayofweek:word; + i,j:integer; + abort,next:boolean; +begin + fn:=allcaps(fn); s:=fn; + if (copy(fn,length(fn)-3,4)='.ANS') then begin + if (exist(copy(fn,1,length(fn)-4)+'.AN1')) then + repeat + i:=random(10); + if (i=0) then + fn:=copy(fn,1,length(fn)-4)+'.ANS' + else + fn:=copy(fn,1,length(fn)-4)+'.AN'+cstr(i); + until (exist(fn)); + + getdate(year,month,day,dayofweek); + s:=fn; s[length(s)-1]:=chr(dayofweek+48); + if (exist(s)) then fn:=s; + end; + pfl(fn,abort,next,TRUE); +end; + +procedure printf(fn:string); { see if an *.ANS file is available } +var ffn,ps,ns,es:string; { if you have ansi graphics invoked } + i,j:integer; +begin + nofile:=TRUE; + fn:=sqoutsp(fn); + if (fn='') then exit; + if (pos('\',fn)<>0) then j:=1 + else begin + j:=2; + fsplit(fexpand(fn),ps,ns,es); + if (not exist(systat.afilepath+ns+'.*')) then + if (not exist(systat.gfilepath+ns+'.*')) then exit; + end; + for i:=1 to j do begin + ffn:=fn; + if ((pos('\',fn)=0) and (pos(':',fn)=0)) then + case i of + 1:ffn:=systat.afilepath+ffn; + 2:ffn:=systat.gfilepath+ffn; + end; + ffn:=fexpand(ffn); + if (pos('.',fn)<>0) then printfile(ffn) + else begin + if ((okansi) and (not okavatar)) and (exist(ffn+'.ans')) then printfile(ffn+'.ans'); + if (nofile) then + if (thisuser.linelen<80) and (exist(ffn+'.40c')) then + printfile(ffn+'.40c') + else + if (exist(ffn+'.msg')) then printfile(ffn+'.msg'); + end; + if (not nofile) then exit; + end; +end; + +procedure skey(c:char); (* Global user keys *) +var ddt,dt:datetimerec; + s:string; + savpap:integer; + bb:byte; +begin + case c of + ^D,^E,^F,^R: + if (macok) and (buf='') then dm(' '+macros.macro[pos(c,^D^E^F^R)],c); + ^T:begin + bb:=curco; + savpap:=pap; + nl; + if (useron) then + sprint('@M'+#3+chr(systat.sysopcolor)+systat.bbsname+ + ' ('+systat.bbsphone+')'); + nl; + sprint(#3#0+'DateTime...: '+#3#9+dat); + if (useron) then begin + sprint(#3#0+'Time left..: '+#3#5+'@T'); + getdatetime(dt); + timediff(ddt,timeon,dt); + sprint(#3#0+'Time on....: '+#3#5+longtim(ddt)); + end; + nl; + pap:=savpap; curco:=bb; sdc; + end; + #127:c:=#8; + end; +end; + +function verline(i:integer):string; +var s:string; +begin + case i of + 1:begin + s:='Project Coyote 0.14 Alpha '; + end; + 2:s:='Complied By Robert Merritt on 11-19-92'; + end; + verline:=s; +end; + +function aacs1(u:userrec; un:integer; s:string):boolean; +var s1,s2:string; + p1,p2,i,j:integer; + c,c1,c2:char; + b:boolean; + + procedure getrest; + begin + s1:=c; + p1:=i; + if ((i<>1) and (s[i-1]='!')) then begin s1:='!'+s1; dec(p1); end; + if (c in ['C','F','G','R','V','X']) then begin + s1:=s1+s[i+1]; + inc(i); + end else begin + j:=i+1; + repeat + if (s[j] in ['0'..'9']) then begin + s1:=s1+s[j]; + inc(j); + end; + until ((j>length(s)) or (not (s[j] in ['0'..'9']))); + i:=j-1; + end; + p2:=i; + end; + + function argstat(s:string):boolean; + var vs:string; + year,month,day,dayofweek,hour,minute,second,sec100:word; + vsi:integer; + boolstate,res:boolean; + begin + boolstate:=(s[1]<>'!'); + if (not boolstate) then s:=copy(s,2,length(s)-1); + vs:=copy(s,2,length(s)-1); vsi:=value(vs); + case s[1] of + 'A':res:=(ageuser(u.bday)>=vsi); + 'B':res:=((value(spd)>=value(vs+'00')) or (spd='KB')); + 'C':res:=FALSE; { conferences - not implemented yet } + 'D':res:=(u.dsl>=vsi); + 'F':res:=(upcase(vs[1]) in u.ar); + 'G':res:=(u.sex=upcase(vs[1])); + 'H':begin + gettime(hour,minute,second,sec100); + res:=(hour=vsi); + end; + 'P':res:=(u.filepoints>=vsi); + 'R':res:=(tacch(upcase(vs[1])) in u.ac); + 'S':res:=(u.sl>=vsi); + 'T':res:=(trunc(nsl) div 60>=vsi); + 'U':res:=(un=vsi); + 'V':res:=((u.sl>systat.newsl) or (u.dsl>systat.newdsl) or + ((systat.newsl=systat.autosl) and (systat.newdsl=systat.autodsl))); + 'W':begin + getdate(year,month,day,dayofweek); + res:=(dayofweek=ord(s[1])-48); + end; + 'Y':res:=(trunc(timer) div 60>=vsi); + end; + if (not boolstate) then res:=not res; + argstat:=res; + end; + +begin + s:=allcaps(s); + i:=0; + while (ilength(s)) then begin + getrest; + b:=argstat(s1); + delete(s,p1,length(s1)); + if (b) then s2:='^' else s2:='%'; + insert(s2,s,p1); + dec(i,length(s1)-1); + end; + end; + s:='('+s+')'; + while (pos('&',s)<>0) do delete(s,pos('&',s),1); + while (pos('^^',s)<>0) do delete(s,pos('^^',s),1); + while (pos('(',s)<>0) do begin + i:=1; + while ((s[i]<>')') and (i<=length(s))) do begin + if (s[i]='(') then p1:=i; + inc(i); + end; + p2:=i; + s1:=copy(s,p1+1,(p2-p1)-1); + while (pos('|',s1)<>0) do begin + i:=pos('|',s1); + c1:=s1[i-1]; c2:=s1[i+1]; + s2:='%'; + if ((c1 in ['%','^']) and (c2 in ['%','^'])) then begin + if ((c1='^') or (c2='^')) then s2:='^'; + delete(s1,i-1,3); + insert(s2,s1,i-1); + end else + delete(s1,i,1); + end; + while(pos('%%',s1)<>0) do delete(s1,pos('%%',s1),1); {leave only "%"} + while(pos('^^',s1)<>0) do delete(s1,pos('^^',s1),1); {leave only "^"} + while(pos('%^',s1)<>0) do delete(s1,pos('%^',s1)+1,1); {leave only "%"} + while(pos('^%',s1)<>0) do delete(s1,pos('^%',s1),1); {leave only "%"} + delete(s,p1,(p2-p1)+1); + insert(s1,s,p1); + end; + aacs1:=(not (pos('%',s)<>0)); +end; + +function aacs(s:string):boolean; +begin + aacs:=aacs1(thisuser,usernum,s); +end; + +{ load account "i" if i<>usernum; else use "thisuser" account } +procedure loadurec(var u:userrec; i:integer); +var ufo:boolean; +begin + ufo:=(filerec(uf).mode<>fmclosed); + if (not ufo) then reset(uf); + if (i<>usernum) then begin + seek(uf,i); + read(uf,u); + end else + u:=thisuser; + if (not ufo) then close(uf); +end; + +{ save account "i" if i<>usernum; save data into "thisuser" account if same } +procedure saveurec(u:userrec; i:integer); +var ufo:boolean; +begin + ufo:=(filerec(uf).mode<>fmclosed); + if (not ufo) then reset(uf); + seek(uf,i); write(uf,u); + if (i=usernum) then thisuser:=u; + if (not ufo) then close(uf); +end; + +end. diff --git a/common1.pas b/common1.pas new file mode 100644 index 0000000..f4851be --- /dev/null +++ b/common1.pas @@ -0,0 +1,829 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit common1; + +interface + +uses + crt, dos, + myio, + tmpcom; + +function checkpw:boolean; +procedure newcomptables; +procedure cline(var s:string; dd:string); +procedure pausescr; +procedure wait(b:boolean); +(*procedure fix_window;*) +procedure inittrapfile; +procedure chatfile(b:boolean); +procedure local_input1(var i:string; ml:integer; tf:boolean); +procedure local_input(var i:string; ml:integer); +procedure local_inputl(var i:string; ml:integer); +procedure local_onek(var c:char; ch:string); +function chinkey:char; +procedure inli1(var s:string); +procedure chat; +procedure sysopshell(takeuser:boolean); +procedure globat(i:integer); +procedure exiterrorlevel; +procedure showsysfunc; +procedure readinzscan; +procedure savezscanr; +procedure redrawforansi; + +implementation + +uses + common, common2, common3; + +var + chcfilter:array[1..2] of cfilterrec; + chcfilteron:boolean; + +function checkpw:boolean; +var s:string[20]; + savsl,savdsl:integer; +begin + checkpw:=TRUE; + prompt('SysOp Password: '); + + savsl:=thisuser.sl; savdsl:=thisuser.dsl; + thisuser.sl:=realsl; thisuser.dsl:=realdsl; + echo:=((aacs(systat.seepw)) and (not systat.localsec)); + thisuser.sl:=savsl; thisuser.dsl:=savdsl; + + input(s,20); + echo:=TRUE; + + if (s<>systat.sysoppw) then + begin + checkpw:=FALSE; + if (incom) and (s<>'') then sysoplog('*** Wrong SysOp Password = '+s+' ***'); + end; +end; + +procedure newcomptables; +var savuboard:ulrec; + savboard:boardrec; + savreaduboard,savreadboard,i,j:integer; + bfo,ulfo,done:boolean; +begin + for i:=0 to 1 do for j:=0 to maxuboards do ccuboards[i][j]:=j; + for i:=0 to 1 do for j:=1 to maxboards do ccboards[i][j]:=j; + if (systat.compressbases) then begin + + savuboard:=memuboard; savreaduboard:=readuboard; + savboard:=memboard; savreadboard:=readboard; + + bfo:=(filerec(bf).mode<>fmclosed); + ulfo:=(filerec(ulf).mode<>fmclosed); + if (not bfo) then reset(bf); + if (not ulfo) then reset(ulf); + + seek(ulf,0); i:=0; j:=0; done:=FALSE; + while ((not done) and (i<=maxuboards)) do begin + {$I-} read(ulf,memuboard); {$I+} + done:=(ioresult<>0); + + + if (not done) then + if (i>maxulb) then begin + ccuboards[0][i]:=maxuboards+1; + ccuboards[1][i]:=maxuboards+1; + end else + if (aacs(memuboard.acs)) then begin + ccuboards[1][i]:=j; ccuboards[0][j]:=i; + inc(j); + end; + inc(i); + end; +{ seek(ulf,loaduboard); read(ulf,memuboard);} + if (maxulb0); + + if (not done) then + if (i>numboards) then begin + ccboards[0][i]:=maxboards+1; + ccboards[1][i]:=maxboards+1; + end else + if (mbaseac(i)) then begin + ccboards[1][i]:=j; ccboards[0][j]:=i; + inc(j); + end; + inc(i); + end; +{ seek(bf,loadboard); read(bf,memboard);} + if (numboardssystat.timeoutbell*60) and (c=#0)) then begin + outkey(^G); delay(100); outkey(^G); + end; + if ((systat.timeout<>-1) and (dt2r(ddt)>systat.timeout*60)) then begin + nl; + nl; + printf('timedout'); + if (nofile) then + print('Time out has occurred. Log off time was at '+time+'.'); + nl; nl; + hangup:=TRUE; + sysoplog(#3#7+'!*!*! Time-out at '+time+' !*!*!'); + exit; + end; + until ((c<>#0) or (hangup)); +*) + + if ((okansi) and (not hangup)) then begin + s:=cstr(x); + if (outcom) then begin + if (okavatar) then pr1(^Y^H+chr(x)+^Y+' '+chr(x)+^Y^H+chr(x)) + else begin + pr1(#27+'['+s+'D'); + for i:=1 to x do pr1(' '); + pr1(#27+'['+s+'D'); + end; + end; + if (wantout) then begin + for i:=1 to x do write(^H); + for i:=1 to x do write(' '); + for i:=1 to x do write(^H); + end; + end else begin + for i:=1 to x do outkey(^H); + for i:=1 to x do outkey(' '); + for i:=1 to x do outkey(^H); + if (trapping) then begin + for i:=1 to x do write(trapfile,^H); + for i:=1 to x do write(trapfile,' '); + for i:=1 to x do write(trapfile,^H); + end; + end; + if (not hangup) then setc(bb); +end; + +procedure wait(b:boolean); +const lastc:byte=0; +var c,len:integer; +begin + if (b) then begin + lastc:=curco; + sprompt(fstring.wait) + end else begin + len:=lenn(fstring.wait); + for c:=1 to len do prompt(^H); + for c:=1 to len do prompt(' '); + for c:=1 to len do prompt(^H); + setc(lastc); + end; +end; + +(*procedure fix_window; +var wind:windowrec; + x,y,i,z:integer; +begin + if (useron) then begin + x:=wherex; y:=wherey; + if (not systat.istopwindow) then begin + if (systat.bwindow) then begin + window(1,1,80,25); + gotoxy(1,25); + if (y>=22) then for i:=1 to 4-(25-y) do writeln; + if (y>=22) then dec(y,4-(25-y)); + end; + gotoxy(x,y); + end else begin + if (systat.bwindow) then begin + window(1,1,80,25); + savescreen(wind,1,1,80,y); + if (y>=22) then z:=25-y else z:=5; + if (z>=2) then movewindow(wind,1,z); + if (z<=4) then y:=(y-z)+1; + if (y>=22) then y:=21; + if (y<=0) then y:=1; + gotoxy(x,y); + end; + end; + if (systat.bwindow) then topscr; + end; +end;*) + +procedure inittrapfile; +begin + if (systat.globaltrap) or (thisuser.trapactivity) then trapping:=TRUE + else trapping:=FALSE; + if (trapping) then begin + if (thisuser.trapseperate) then + assign(trapfile,systat.trappath+'trap'+cstr(usernum)+'.msg') + else + assign(trapfile,systat.trappath+'trap.msg'); + {$I-} append(trapfile); {$I+} + if (ioresult<>0) then begin + rewrite(trapfile); + writeln(trapfile); + end; + writeln(trapfile,'***** TeleGard-X User Audit - '+nam+' on at '+date+' '+time+' *****'); + end; +end; + +procedure chatfile(b:boolean); +var bf:file of byte; + s:string[91]; + cr:boolean; +begin + s:='chat'; + if (thisuser.chatseperate) then s:=s+cstr(usernum); + s:=systat.trappath+s+'.msg'; + if (not b) then begin + if (cfo) then begin + commandline('Chat Capture OFF (Recorded in "'+s+'")'); + cfo:=FALSE; + if (textrec(cf).mode<>fmclosed) then close(cf); + end; + end else begin + cfo:=TRUE; + if (textrec(cf).mode=fmoutput) then close(cf); + assign(cf,s); assign(bf,s); + cr:=FALSE; + {$I-} reset(cf); {$I+} + if (ioresult<>0) then + rewrite(cf) + else begin + close(cf); + append(cf); + end; + writeln(cf,^M^J^M^J+dat+^M^J+'Recorded with user: '+nam+^M^J+'------------------------------------'+^M^J); + commandline('Chat Capture ON ("'+s+'")'); + end; +end; + +procedure local_input1(var i:string; ml:integer; tf:boolean); +var r:real; + cp:integer; + cc:char; +begin + cp:=1; + repeat + cc:=readkey; + if (not tf) then cc:=upcase(cc); + if (cc in [#32..#255]) then + if (cp<=ml) then begin + i[cp]:=cc; + inc(cp); + write(cc); + end + else + else + case cc of + ^H:if (cp>1) then begin + cc:=^H; + write(^H' '^H); + dec(cp); + end; + ^U,^X:while (cp<>1) do begin + dec(cp); + write(^H' '^H); + end; + end; + until (cc in [^M,^N]); + i[0]:=chr(cp-1); + if (wherey<=hi(windmax)-hi(windmin)) then writeln; +end; + +procedure local_input(var i:string; ml:integer); (* Input uppercase only *) +begin + local_input1(i,ml,FALSE); +end; + +procedure local_inputl(var i:string; ml:integer); (* Input lower & upper case *) +begin + local_input1(i,ml,TRUE); +end; + +procedure local_onek(var c:char; ch:string); (* 1 key input *) +begin + repeat c:=upcase(readkey) until (pos(c,ch)>0); + writeln(c); +end; + +function chinkey:char; +var c:char; +begin + c:=#0; chinkey:=#0; + if (keypressed) then begin + c:=readkey; + if (chcfilteron) then setc(chcfilter[1][ord(c)]) + else if (not wcolor) then cl(systat.sysopcolor); + wcolor:=TRUE; + if (c=#0) then + if (keypressed) then begin + c:=readkey; + skey1(c); + if (c=#68) then c:=#1 else c:=#0; + if (buf<>'') then begin + c:=buf[1]; + buf:=copy(buf,2,length(buf)-1); + end; + end; + chinkey:=c; + end else + if ((not com_rx_empty) and (incom) and (not trm)) then begin + c:=cinkey; + if (chcfilteron) then setc(chcfilter[2][ord(c)]) + else if (wcolor) then cl(systat.usercolor); + wcolor:=FALSE; + chinkey:=c; + end; +end; + +procedure inli1(var s:string); (* Input routine for chat *) +var cv,cc,cp,g,i,j:integer; + c,c1:char; +begin + cp:=1; + s:=''; + if (ll<>'') then begin + if (chcfilteron) then begin + if (wcolor) then j:=1 else j:=2; + for i:=1 to length(ll) do begin + setc(chcfilter[j][ord(ll[i])]); + outkey(ll[i]); + if (trapping) then write(trapfile,ll[i]); + end; + end else + prompt(ll); + s:=ll; ll:=''; + cp:=length(s)+1; + end; + repeat + getkey(c); checkhangup; + case ord(c) of + 32..255:if (cp<79) then begin + s[cp]:=c; pap:=cp; inc(cp); + outkey(c); + if (trapping) then write(trapfile,c); + end; + 16:if okansi then begin + getkey(c1); + cl(ord(c1)-48); + end; + 27:if (cp<79) then begin + s[cp]:=c; inc(cp); + outkey(c); + if (trapping) then write(trapfile,c); + end; + 8:if (cp>1) then begin + dec(cp); pap:=cp; + prompt(^H' '^H); + end; + 24:begin + for cv:=1 to cp-1 do prompt(^H' '^H); + cp:=1; + pap:=0; + end; + 7:if (outcom) then sendcom1(^G); + 23:if cp>1 then + repeat + dec(cp); pap:=cp; + prompt(^H' '^H); + until (cp=1) or (s[cp]=' '); + 9:begin + cv:=5-(cp mod 5); + if (cp+cv<79) then + for cc:=1 to cv do begin + s[cp]:=' '; + inc(cp); pap:=cp; + prompt(' '); + end; + end; + end; + until ((c=^M) or (cp=79) or (hangup) or (not ch)); + if (not ch) then begin c:=#13; ch:=FALSE; end; + s[0]:=chr(cp-1); + if (c<>^M) then begin + cv:=cp-1; + while (cv>0) and (s[cv]<>' ') and (s[cv]<>^H) do dec(cv); + if (cv>(cp div 2)) and (cv<>cp-1) then begin + ll:=copy(s,cv+1,cp-cv); + for cc:=cp-2 downto cv do prompt(^H); + for cc:=cp-2 downto cv do prompt(' '); + s[0]:=chr(cv-1); + end; + end; + if (wcolor) then j:=1 else j:=2; + if ((chcfilteron) and ((chcfilter[j][32] and 112)<>0)) then begin + setc(chcfilter[j][32]); + if (okavatar) then pr1(^V+^G) else pr1(^['[K'); + clreol; + setc(7); + nl; + setc(chcfilter[j][32]); + end else + nl; +end; + +procedure loadchcfilter(i:integer); +var chcfilterf:file of cfilterrec; + s,os:string; + ps:string[67]; + ns:string[8]; + es:string[4]; +begin + os:=s; + if (i=1) then s:=systat.chatcfilter1 else s:=systat.chatcfilter2; + + if (s='') then begin + sysoplog(aonoff((i=1),'SysOp','User')+' chat-filter set to NULL string'); + exit; + end; + + fsplit(s,ps,ns,es); + if (exist(systat.afilepath+ns+es)) then s:=systat.afilepath+ns+es + else + if (exist(systat.gfilepath+ns+es)) then s:=systat.gfilepath+ns+es; + + assign(chcfilterf,s); + {$I-} reset(chcfilterf); {$I+} + if (ioresult=0) then begin + {$I-} read(chcfilterf,chcfilter[i]); {$I+} + if (ioresult=0) then chcfilteron:=TRUE; + close(chcfilterf); + end else + sysoplog('Missing chat color filter: "'+os+'"'); +end; + +procedure chat; +var chatstart,chatend,tchatted:datetimerec; + s,xx:string; + t1:real; + i,savpap:integer; + c:char; + savecho,savprintingfile:boolean; +begin + nosound; + getdatetime(chatstart); + dosansion:=FALSE; + + savprintingfile:=printingfile; + savpap:=pap; ch:=TRUE; chatcall:=FALSE; savecho:=echo; echo:=TRUE; + if (systat.autochatopen) then chatfile(TRUE) + else if (thisuser.chatauto) then chatfile(TRUE); + nl; nl; + thisuser.ac:=thisuser.ac-[alert]; + + printf('chatinit'); + if (nofile) then begin sprompt(#3#5+fstring.engage); nl; nl; end; + + cl(systat.sysopcolor); wcolor:=TRUE; + + chcfilteron:=FALSE; + + if (okansi) then + if ((systat.chatcfilter1<>'') or (systat.chatcfilter2<>'')) then begin + loadchcfilter(1); + if (chcfilteron) then loadchcfilter(2); + end; + + if (chatr<>'') then begin + commandline(chatr); print(' '); chatr:=''; + end; + repeat + inli1(xx); + if (xx[1]='/') then xx:=allcaps(xx); + if (copy(xx,1,6)='/TYPE ') then begin + s:=copy(xx,7,length(xx)); + if (s<>'') then begin + printfile(s); + if (nofile) then print('*File not found*'); + end; + end + else if (xx='/SHELL') and (thisuser.sl=255) then begin + print('Shelling to DOS...'); + sysopshell(TRUE) + end + else if (xx='/CC') then begin + print(syn(dosansion)); + end + else if (xx='/C') then begin + print(syn(mtcolors)); + end + else if ((xx='/HELP') or (xx='/?')) then begin + nl; + sprint('^5/TYPE d:\path\filename.ext^3: Type a file'); + sprint('^5/BYE^3: Hang up'); + sprint('^5/CLS^3: Clear the screen'); + sprint('^5/PAGE^3: Page the SysOp and User'); + if (thisuser.sl=255) then + sprint('^5/SHELL^3: Shell to DOS with user (255 SL ^5ONLY^3)'); + sprint('^5/Q^3: Exit chat mode'); + nl; + end + else if (xx='/CLS') then cls + else if (xx='/PAGE') then begin + for i:=650 to 700 do begin + sound(i); delay(4); + nosound; + end; + repeat + dec(i); sound(i); delay(2); + nosound; + until (i=200); + prompt(^G^G); + end + + else if (xx='/ACS') then begin + prt('ACS:'); inputl(s,20); + if (aacs(s)) then print('You have access to that!') + else print('You DO NOT have access to that.'); + end + + else if (xx='/BYE') then begin + print('Hanging up...'); + hangup:=TRUE; + end + else if (xx='/Q') then begin + t1:=timer; + while (abs(t1-timer)<0.6) and (empty) do; + if (empty) then begin ch:=FALSE; print('Chat Aborted...'); end; + end; + if (cfo) then writeln(cf,xx); + until ((not ch) or (hangup)); + + printf('chatend'); + if (nofile) then begin nl; sprint(#3#5+fstring.endchat); end; + + getdatetime(chatend); + timediff(tchatted,chatstart,chatend); + + freetime:=freetime+dt2r(tchatted); + + tleft; + s:='Chatted for '+longtim(tchatted); + if (cfo) then begin + s:=s+' -{ Recorded in CHAT'; + if (thisuser.chatseperate) then s:=s+cstr(usernum); + s:=s+'.MSG }-'; + end; + sysoplog(s); + ch:=FALSE; echo:=savecho; + if ((hangup) and (cfo)) then + begin + writeln(cf); + writeln(cf,'NO CARRIER'); + writeln(cf); + writeln(cf,'>> Carrier lost ...'); + writeln(cf); + end; + pap:=savpap; printingfile:=savprintingfile; + commandline(''); + if (cfo) then chatfile(FALSE); +end; + +procedure sysopshell(takeuser:boolean); +var wind:windowrec; + opath:string; + t:real; + sx,sy,ret:integer; + bb:byte; + + procedure dosc; + var s:string; + i:integer; + begin + s:=^M^J+#27+'[0m'; + for i:=1 to length(s) do dosansi(s[i]); + end; + +begin + bb:=curco; + getdir(0,opath); + t:=timer; + if (useron) and (incom) then begin + nl; nl; + sprompt(fstring.shelldos1); + end; + sx:=wherex; sy:=wherey; + setwindow(wind,1,1,80,25,7,0,0); + clrscr; + tc(11); writeln('[> Type "EXIT" to return to Project Coyote.'); + dosc; + dosansion:=FALSE; + if (not takeuser) then shelldos(FALSE,'',ret) + else shelldos(FALSE,'remote.bat',ret); + getdatetime(tim); + if (useron) then com_flush_rx; + if (not trm) then chdir(opath); + clrscr; + removewindow(wind); + gotoxy(sx,sy); + if (useron) then begin + freetime:=freetime+timer-t; + topscr; + sdc; + if (incom) then begin + nl; + sprint(fstring.shelldos2); + end; + end; + setc(bb); +end; + +procedure globat(i:integer); +var wind:windowrec; + s:string; + t:real; + xx,yy,z,ret:integer; +begin + xx:=wherex; yy:=wherey; z:=textattr; + getdir(0,s); + chdir(start_dir); + savescreen(wind,1,1,80,25); + t:=timer; + shelldos(FALSE,'globat'+chr(i+48),ret); + getdatetime(tim); + com_flush_rx; + freetime:=freetime+timer-t; + removewindow(wind); + chdir(s); + if (useron) then topscr; + gotoxy(xx,yy); textattr:=z; +end; + +procedure exiterrorlevel; +var wind:windowrec; + s:string; + xx,yy,z,ee:integer; + c:char; + re:boolean; +begin + savescreen(wind,1,1,80,25); + xx:=wherex; yy:=wherey; z:=textattr; + clrscr; + writeln('[> Exit at ERRORLEVEL '+cstr(exiterrors)+', correct? '); + writeln; + write('[A]bort [Y]es [O]ther : '); + repeat c:=upcase(readkey) until (c in ['A','Y','O',^M]); + if (c<>^M) then write(c); + writeln; + ee:=-1; + case c of + 'O':begin + writeln; + write('Enter ERRORLEVEL (-1 to abort) : '); + readln(s); + if (s<>'') then ee:=value(s); + end; + 'Y':ee:=exiterrors; + end; + if (ee<>-1) then begin + writeln; + write('Generate a run-time error? [Yes] : '); + repeat c:=upcase(readkey) until (c in ['Y','N',^M]); + re:=(c<>'N'); + end; + removewindow(wind); + if (useron) then topscr; + gotoxy(xx,yy); textattr:=z; + if (ee<>-1) then begin + exiterrors:=ee; + if (re) then runerror(0) else halt(ee); + end; +end; + +procedure showsysfunc; +var imagef:file of windowrec; + wind,swind:windowrec; + xx,yy,z:integer; + c:char; + badd:boolean; +begin + assign(imagef,systat.gfilepath+'sysfunc.dat'); + {$I-} reset(imagef); {$I+} + if (ioresult<>0) then commandline('"'+systat.gfilepath+'SYSFUNC.DAT" missing') + else begin + {$I-} read(imagef,wind); {$I+} badd:=(ioresult<>0); + if (badd) then commandline('Errors reading image data from SYSFUNC.DAT'); + close(imagef); + if (not badd) then begin + savescreen(swind,1,1,80,25); + xx:=wherex; yy:=wherey; z:=textattr; + removewindow(wind); + cursoron(FALSE); + c:=readkey; + removewindow(swind); + if (useron) then topscr; + gotoxy(xx,yy); textattr:=z; + cursoron(TRUE); + end; + end; +end; + +procedure readinzscan; +var zscanf:file of zscanrec; + i,j:integer; +begin + assign(zscanf,systat.gfilepath+'zscan.dat'); + {$I-} reset(zscanf); {$I+} if (ioresult<>0) then rewrite(zscanf); + if (usernum=usernum+1); + close(zscanf); +end; + +procedure savezscanr; +var zscanf:file of zscanrec; +begin + assign(zscanf,systat.gfilepath+'zscan.dat'); + {$I-} reset(zscanf); {$I+} if (ioresult<>0) then rewrite(zscanf); + if (usernum2) then i:=1; + end else + systat.windowon:=TRUE; + schangewindow(TRUE,i); + end; + SHIFT_F2: + if (useron) then + if (not systat.windowon) then begin + systat.windowon:=TRUE; + cwindowon:=TRUE; + schangewindow(TRUE,systat.curwindow); + end else begin + sclearwindow; + systat.windowon:=FALSE; + end; + F3: + if (not com_carrier) then commandline('No carrier detected!') + else begin + if (outcom) then + if (incom) then incom:=FALSE else + if (com_carrier) then incom:=TRUE; + if (incom) then commandline('User keyboard ON.') + else commandline('User keyboard OFF.'); + com_flush_rx; + end; + F4: + begin + chatcall:=FALSE; chatr:=''; + thisuser.ac:=thisuser.ac-[alert]; tleft; + end; + F5:hangup:=TRUE; + F6:if (useron) then topscr; + F7: + begin + b:=ch; ch:=TRUE; + dec(thisuser.tltoday,5); + tleft; + ch:=b; + end; + F8: + begin + b:=ch; ch:=TRUE; + inc(thisuser.tltoday,5); + if (thisuser.tltoday<0) then thisuser.tltoday:=32767; + tleft; + ch:=b; + end; + F9: + if (useron) then + with thisuser do begin + if (sl=255) then + if (realsl<>255) or (realdsl<>255) then begin + thisuser.sl:=realsl; + thisuser.dsl:=realdsl; + if (systat.compressbases) then newcomptables; + topscr; commandline('Normal access restored.'); + end else + else begin + realsl:=sl; realdsl:=dsl; + thisuser.sl:=255; + thisuser.dsl:=255; + if (systat.compressbases) then newcomptables; + topscr; commandline('Temporary SysOp access granted.'); + end; + end; + F10: + if (ch) then begin + ch:=FALSE; + chatr:=''; + end else + chat; + ARROW_HOME: + if (ch) then chatfile(not cfo); + ARROW_UP, + ARROW_LEFT, + ARROW_RIGHT, + ARROW_DOWN: + if ((ch) or (write_msg)) then begin + if (okavatar) then buf:=buf+^V else buf:=buf+^[+'['; + case ord(c) of + ARROW_UP:if (okavatar) then buf:=buf+^C else buf:=buf+'A'; + ARROW_LEFT:if (okavatar) then buf:=buf+^E else buf:=buf+'D'; + ARROW_RIGHT:if (okavatar) then buf:=buf+^F else buf:=buf+'C'; + ARROW_DOWN:if (okavatar) then buf:=buf+^D else buf:=buf+'B'; + end; + end; + SHIFT_F3: + if (outcom) then begin + savwantout:=wantout; wantout:=FALSE; + wait(TRUE); + wantout:=savwantout; + commandline('User screen OFF ³ User keyboard OFF'); + outcom:=FALSE; incom:=FALSE; + end else + if (not com_carrier) then commandline('No carrier detected!') + else begin + commandline('User screen ON ³ User keyboard ON'); + savwantout:=wantout; wantout:=FALSE; + wait(FALSE); + wantout:=savwantout; + outcom:=TRUE; incom:=TRUE; + end; + SHIFT_F5: + begin + cline(s,'Display what hangup file (HANGUPxx.*) :'); + commandline(''); + if (s<>'') then begin + nl; nl; incom:=FALSE; + printf('hangup'+s); + sysoplog('++ Displayed hangup file HANGUP'+s); + hangup:=TRUE; + end; + end; + SHIFT_F7: + begin + wait(TRUE); + cline(s,'Subtract from user''s time left: '); + commandline(''); + if (s<>'') then begin + b:=ch; ch:=TRUE; + dec(thisuser.tltoday,value(s)); + tleft; + ch:=b; + end; + wait(FALSE); + end; + SHIFT_F8: + begin + wait(TRUE); + cline(s,'Add to user''s time left: '); + commandline(''); + if (s<>'') then begin + b:=ch; ch:=TRUE; + inc(thisuser.tltoday,value(s)); + if (thisuser.tltoday<=0) then thisuser.tltoday:=32767; + tleft; + ch:=b; + end; + wait(FALSE); + end; + SHIFT_F10: + begin + beepend:=not beepend; + b:=ch; ch:=TRUE; + tleft; ch:=b; + end; + ALT_F3: + if (wantout) then begin + clrscr; tc(11); writeln('Text OFF'); + wantout:=FALSE; + cursoron(FALSE); + end else begin + clrscr; tc(11); writeln('Text ON'); + wantout:=TRUE; + cursoron(TRUE); + end; + ALT_J, + ALT_F4:SysopShell(FALSE); + ALT_F5: + begin + randomize; + for i:=1 to 50 do prompt(chr(random(255))); + hangup:=TRUE; + end; + ALT_F9: + begin + repeat + outkey(^G); + commandline('Paging user...'); + delay(100); + commandline(''); + checkhangup; + until ((not empty) or (hangup)); + end; + ALT_F10:commandline(chatr); + CTRL_F4:SysopShell(TRUE); + CTRL_F5: + begin + randomize; + s:=''; + for i:=1 to random(50) do s:=s+chr(random(255)); + prompt(s); (* dm(' '+s,c); *) + end; + end; + end; +end; + +procedure savesystat; +var systatf:file of systatrec; +begin + assign(systatf,start_dir+'\status.dat'); + rewrite(systatf); write(systatf,systat); close(systatf); +end; + +procedure setacch(c:char; b:boolean; var u:userrec); +begin + if (b) then if (not (tacch(c) in u.ac)) then acch(c,u); + if (not b) then if (tacch(c) in u.ac) then acch(c,u); +end; + +procedure remove_port; +begin + if (not localioonly) then com_deinstall; +end; + +procedure openport(comport:byte; baud:longint; parity:char; + databits,stopbits:byte); +begin + if (not localioonly) then begin + com_set_parity(com_none,stopbits); + com_set_speed(baud); + end; +end; + +procedure iport; +var anyerrors:word; +begin + if (not localioonly) then begin + if (com_installed) then com_deinstall; + com_install(modemr.comport,anyerrors,systat.fossil); + openport(modemr.comport,modemr.waitbaud,'N',8,1); + end; +end; + +procedure gameport; +var speed:longint; +begin + if (not localioonly) then begin + if (spd='KB') then speed:=modemr.waitbaud else speed:=value(spd); + if ((not modemr.noforcerate) or (value(spd)<9600)) then + openport(modemr.comport,speed,'N',8,1); + end; +end; + +procedure sendcom1(c:char); +begin + if (not localioonly) then com_tx(c); +end; + +function recom1(var c:char):boolean; +begin + c:=#0; + if (localioonly) then recom1:=TRUE else begin + if (not com_rx_empty) then begin + c:=com_rx; + recom1:=TRUE; + end else + recom1:=FALSE; + end; +end; + +procedure term_ready(ready_status:boolean); +var mcr_value:byte; +begin + if (not localioonly) then + if (ready_status) then com_raise_dtr else com_lower_dtr; +end; + +function getwindysize(wind:integer):integer; +begin + case wind of + 0:getwindysize:=0; + 1:getwindysize:=5; + 2:getwindysize:=11; + end; +end; + +procedure inuserwindow; +begin + if (cwindowon) then + if (systat.istopwindow) then + window(1,getwindysize(systat.curwindow)+1,80,25) + else + window(1,1,80,25-getwindysize(systat.curwindow)); +end; + +procedure commandline(s:string); +var p,xx,yy:integer; + sx,sy,sz:byte; +begin + if (not useron) then exit; + + sx:=wherex; sy:=wherey; sz:=textattr; + p:=40-(length(s) div 2); + + window(1,1,80,25); + xx:=4; yy:=1; + if (not cwindowon) then xx:=1 else + if (systat.istopwindow) then + yy:=getwindysize(systat.curwindow) + else + yy:=26-getwindysize(systat.curwindow); + + gotoxy(xx,yy); + if (not ismono) then textattr:=$1F else textattr:=$70; + if (not cwindowon) then clreol else + write(' '); + gotoxy(xx,yy); write(s); + + inuserwindow; + gotoxy(sx,sy); textattr:=sz; +end; + +procedure clrline(y:integer); +begin + gotoxy(1,y); clreol; +end; + +procedure sclearwindow; +var wind:windowrec; + i,windysize:integer; + x,y,z:byte; +begin + if ((not cwindowon) or (not useron) or (not systat.windowon)) then exit; + + x:=wherex; y:=wherey; z:=textattr; + windysize:=getwindysize(systat.curwindow); + cursoron(FALSE); + + window(1,1,80,25); textattr:=7; + if (not systat.istopwindow) then + for i:=26-windysize to 25 do clrline(i) + else begin + savescreen(wind,1,windysize+1,80,25); + for i:=1 to windysize do clrline(i); + movewindow(wind,1,1); + for i:=26-windysize to 25 do clrline(i); + end; + cwindowon:=FALSE; + + gotoxy(x,y); textattr:=z; + cursoron(TRUE); +end; + +procedure schangewindow(needcreate:boolean; newwind:integer); +var wind:windowrec; + i,j,k,windysize,z:integer; + sx,sy,sz:byte; +begin + if (((not useron) and (not needcreate)) or (not systat.windowon)) then exit; + + sx:=wherex; sy:=wherey; sz:=textattr; + windysize:=getwindysize(newwind); + + if (not needcreate) then needcreate:=(newwind<>systat.curwindow); + if ((windysize<>getwindysize(systat.curwindow)) and (cwindowon)) then + sclearwindow; + + if (not systat.istopwindow) then begin + cursoron(FALSE); + if ((needcreate) and (newwind in [1,2])) then begin + window(1,1,80,25); + gotoxy(1,25); + if (sy>25-windysize) then begin + z:=windysize-(25-sy); + for i:=1 to z do writeln; + dec(sy,z); + end; + end; + gotoxy(sx,sy); + end else begin + if ((needcreate) and (newwind in [1,2])) then begin + window(1,1,80,25); + savescreen(wind,1,1,80,sy); + if (sy<=25-windysize) then z:=windysize+1 else z:=26-sy; + if (z>=2) then movewindow(wind,1,z); + if (z<=4) then sy:=(sy-z)+1; + + if (sy>25-windysize) then sy:=25-windysize; + if (sy<1) then sy:=1; + end; + cursoron(TRUE); + end; + + systat.curwindow:=newwind; + if (systat.curwindow<>0) then cwindowon:=TRUE; + gotoxy(sx,sy); textattr:=sz; + if (systat.curwindow in [1,2]) then topscr; +end; + +procedure blankzlog(var zz:zlogrec); +var i:integer; +begin + with zz do begin + date:=' ------ '; + for i:=0 to 4 do userbaud[i]:=0; + active:=0; calls:=0; newusers:=0; pubpost:=0; privpost:=0; + fback:=0; criterr:=0; uploads:=0; downloads:=0; uk:=0; dk:=0; + end; +end; + +function mrnn(i,l:integer):string; +begin + mrnn:=mrn(cstr(i),l); +end; + +function ctp(t,b:longint):string; +var s,s1:string[32]; + n:real; +begin + s:=cstr((t*100) div b); + if (length(s)=1) then s:=' '+s; + s:=s+'.'; + if (length(s)=3) then s:=' '+s; + n:=t/b+0.0005; + s1:=cstr(trunc(n*1000) mod 10); + ctp:=s+s1+'%'; +end; + +procedure topscr; +var zf:file of zlogrec; + zz:array[1..3] of zlogrec; + s,spe:string; + i,j,k,windysize:integer; + sx,sy,sz:byte; + c:char; +begin + if ((usernum=0) or (not cwindowon) or (not useron)) then exit; + + cursoron(FALSE); + sx:=wherex; sy:=wherey; sz:=textattr; + window(1,1,80,25); windysize:=getwindysize(systat.curwindow); + textbackground(0); + + if (systat.istopwindow) then window(1,1,80,windysize) + else window(1,26-windysize,80,25); + for i:=1 to windysize do begin gotoxy(1,i); clreol; end; + + if (systat.istopwindow) then gotoxy(1,windysize) else gotoxy(1,1); + tc(9); textbackground(1); clreol; textbackground(0); + + if (systat.istopwindow) then window(1,1,80,windysize-1) + else window(1,27-windysize,80,25); + + with thisuser do + case systat.curwindow of + 1:begin + cwriteat(1,1, #3#11+nam); + cwriteat(36,1,#3#14+'PS:'+#3#11+mn(msgpost,6)+ + #3#14+'ES:'+#3#11+mn(emailsent,6)+ + #3#14+'FS:'+#3#11+mn(feedback,4)+ + #3#14+'MW:'+#3#11+mn(waiting,3)); + cwrite(#3#14+'UL:'+#3#11+cstr(uploads)+'-'+cstr(uk)+'k'); + cwriteat(1,2, #3#11+realname); + cwriteat(36,2,#3#14+'TC:'+#3#11+mn(loggedon,6)+ + #3#14+'TT:'+#3#11+mn(ttimeon,6)+ + #3#14+'CT:'+#3#11+mn(ontoday,4)+ + #3#14+'IL:'+#3#11+mn(illegal,3)); + cwrite(#3#14+'DL:'+#3#11+cstr(downloads)+'-'+cstr(dk)+'k'); + spe:=spd; + if (length(spe)=5) then spe:=copy(spe,1,2)+'.'+copy(spe,3,1); + if (spe='KB') then spe:='Keys'; + cwriteat(1,3, #3#10+note); + cwriteat(36,3,#3#11+sex+mn(ageuser(bday),2)+ + #3#14+'('+#3#11+bday+#3#14+') '+ + #3#14+'LO:('+#3#11+laston+#3#14+') '+ + #3#9+'['+spe+'] '+ + #3#14+'Pts:'+#3#11+cstr(filepoints)); + cwriteat(1,4, #3#14+'SL:'+#3#11+mn(sl,4)+ + #3#14+'DSL:'+#3#11+mn(dsl,4)+ + #3#14+'AR:'); + for c:='A' to 'Z' do begin + if (c in ar) then tc(4) else tc(7); + write(c); + end; + cwrite(#3#14+' AC:'); + if (ismono) then cpr($70,$07,thisuser) else cpr(4,7,thisuser); + end; + 2:begin + if ((aacs(systat.nodlratio)) or (fnodlratio in thisuser.ac)) then + s:=#3#10+'Exempt' + else + s:=#3#11+'1/'+cstr(systat.dlratio[thisuser.sl])+ + '-1k/'+cstr(systat.dlkratio[thisuser.sl])+'k'; + cwriteat(1,1, #3#11+caps(name)+' ('+caps(realname)+')'); + cwriteat(38,1,#3#11+sex+mn(ageuser(bday),2)+'('+bday+') '+ + #3#14+'FileRatio='+s); + + if ((aacs(systat.nopostratio)) or (fnopostratio in thisuser.ac)) then + s:=#3#10+'Exempt' + else begin + i:=systat.postratio[thisuser.sl]; + s:=#3#11+cstr(i div 10)+'.'+cstr(i mod 10)+' calls/1 post'; + end; + cwriteat(1,2, #3#14+street); + cwriteat(38,2,#3#14+'FO:('+#3#11+firston+#3#14+') '+ + 'PostRatio='+s); + + cwriteat(1,3, #3#14+citystate+' '+zipcode); + cwriteat(38,3,#3#14+'LO:('+#3#11+laston+#3#14+') AR='); + for c:='A' to 'Z' do begin + if (c in ar) then tc(4) else tc(7); + write(c); + end; + + cwriteat(1,4, #3#11+stripcolor(computer)+ + ' ('+cstr(linelen)+'x'+cstr(pagelen)+')'); + cwriteat(38,4,#3#14+ph+' AC='); + if (ismono) then cpr($70,$07,thisuser) else cpr(4,7,thisuser); + + cwriteat(1,5, #3#10+note); + cwriteat(50,5,#3#14+'SL='+#3#11+mn(sl,4)+ + #3#14+'DSL='+#3#11+mn(dsl,3)); + + cwriteat(1,6, #3#9+'ÄÄÄÄÄÄÄÄÂ'+#3#11+'Mins'+ + #3#9+'ÄÂÄÄÄÄÂÄÄÄÄÄÄÂ'+#3#11+'#New'+ + #3#9+'Â'+#3#11+'Tim/'+ + #3#9+'Â'+#3#11+'Pub'+ + #3#9+'ÄÂ'+#3#11+'Priv'+ + #3#9+'Â'+#3#11+'Feed'+ + #3#9+'ÂÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄ'); + + cwriteat(1,7, #3#11+' Date Activ Call %Activ User User '+ + 'Post Post Back Errs Uploads Downloads'); + + zz[1]:=systat.todayzlog; + + assign(zf,systat.gfilepath+'zlog.dat'); + {$I-} reset(zf); {$I+} + if (ioresult=0) then begin + if (eof(zf)) then blankzlog(zz[2]) else read(zf,zz[2]); + if (eof(zf)) then blankzlog(zz[3]) else read(zf,zz[3]); + close(zf); + end else begin + blankzlog(zz[2]); + blankzlog(zz[3]); + end; + + textcolor(9); + for i:=7 to 10 do + for j:=1 to 12 do begin + case j of + 1:k:=9; 2:k:=15; 3:k:=20; 4:k:=27; 5:k:=32; 6:k:=37; + 7:k:=42; 8:k:=47; 9:k:=52; 10:k:=57; 11:k:=68; 12:k:=79; + end; + gotoxy(k,i); write('³'); + end; + + textcolor(14); + for i:=1 to 3 do begin + if (i=2) then textcolor(11); + if (i=1) then cwriteat(1,8,'Today''s') + else cwriteat(1,i+7,zz[i].date); + cwriteat(10,i+7,mrnn(zz[i].active,5)); + cwriteat(16,i+7,mrnn(zz[i].calls,4)); + cwriteat(21,i+7,ctp(zz[i].active,1440)); + cwriteat(28,i+7,mrnn(zz[i].newusers,4)); + if (zz[i].calls>0) then s:=mrnn(zz[i].active div zz[i].calls,4) + else s:=''; + cwriteat(33,i+7,s); + cwriteat(38,i+7,mrnn(zz[i].pubpost,4)); + cwriteat(43,i+7,mrnn(zz[i].privpost,4)); + cwriteat(48,i+7,mrnn(zz[i].fback,4)); + cwriteat(53,i+7,mrnn(zz[i].criterr,4)); + cwriteat(58,i+7,mn(zz[i].uploads,3)+'-'+cstr(zz[i].uk)+'k'); + cwriteat(69,i+7,mn(zz[i].downloads,3)+'-'+cstr(zz[i].dk)+'k'); + end; + end; + end; + +(* with thisuser do begin + gotoxy(2,1); + tc(14); write(nam+' '); tc(11); write('('+realname+')'); + tc(14); + gotoxy(2,2); write('SL= AR='); + gotoxy(2,3); write('DSL= AC='); + tc(11); + gotoxy(6,2); if res[1]<>255 then write(sl) else write(res[2]); + gotoxy(6,3); if res[1]<>255 then write(dsl) else write(res[3]); + gotoxy(13,2); + for c:='A' to 'Z' do begin + if (c in ar) then tc(4) else tc(7); + write(c); + end; + gotoxy(13,3); cpr(7,thisuser); + gotoxy(28,3); write(' '); + + tc(10); + gotoxy(40,1); write(note); + tc(14); + gotoxy(40,2); write(stripcolor(computer)+' (',linelen,'x',pagelen,')'); + gotoxy(40,3); write(ph); + tc(9); + spe:=spd; + if (length(spe)=5) then spe:=copy(spe,1,2)+'.'+copy(spe,3,1); + if (spe='KB') then spe:='Keys'; + gotoxy(61,3); write('['+spe+']'); + tc(11); + gotoxy(76,2); write(sex,ageuser(bday)); + end;*) + + commandline(chatr); + textbackground(0); + inuserwindow; + gotoxy(sx,sy); textattr:=sz; + sde; + tleft; + cursoron(TRUE); +end; + +procedure gotopx(i:integer; dy:integer); +var y:integer; +begin + if (systat.istopwindow) then y:=getwindysize(systat.curwindow)-1 + else y:=25; + if (systat.curwindow=2) then dec(y,5); + gotoxy(i,y+dy); +end; + +procedure tleft; +var s:string[16]; + lng:longint; + zz:integer; + sx,sy,sz:byte; +begin + stsc; + if ((usernum<>0) and (cwindowon) and (useron)) then begin + cursoron(FALSE); + sx:=wherex; sy:=wherey; sz:=textattr; + window(1,1,80,25); + gotopx(65,0); clreol; + if (hangup) then cwrite(#3#21+'Ä'+#3#29+'DROP'+#3#21+'Ä') else + if (doneafternext) then cwrite(#3#20+'Í'+#3#30+'DNXT'+#3#20+'Í') else + if (beepend) then cwrite(#3#20+'<'+#3#28+'('+#3#14+'**'+#3#28+')'+#3#20+'>') else + if (trapping) then cwrite(#3#20+'Ä'+#3#30+'TRAP'+#3#20+'Ä') else + if (alert in thisuser.ac) then cwrite(#3#20+'Ä'+#3#30+'ALRT'+#3#20+'Ä') else + if (chatr<>'') then cwrite(#3#25+'Ä'+#3#27+'CHAT'+#3#25+'Ä'); + gotopx(72,0); + cwrite(#3#7+'TL='+cstrl(trunc(nsl/60))); + if (sysop) then cwrite(#3#15+'*'); + if (systat.curwindow=2) then begin + gotopx(72,-1); + if (thisuser.chatauto) then s:=#3#15 else + if (systat.autochatopen) then s:=#3#11 else s:=#3#8; + s:=s+'C'; + if (thisuser.chatseperate) then s:=s+#3#15+'S' else + s:=s+#3#8+'S'; + if (thisuser.trapactivity) then s:=s+#3#15+'T' else + if (systat.globaltrap) then s:=s+#3#11+'T' else s:=s+#3#8+'T'; + if (thisuser.trapseperate) then s:=s+#3#15+'S' else + s:=s+#3#8+'S'; + cwrite(s); + end; + inuserwindow; + gotoxy(sx,sy); textattr:=sz; + cursoron(TRUE); + end; + if ((nsl<0) and (choptime<>0.0)) then begin + sysoplog('++ Logged user off in preparation for system event'); + nl; nl; + sprint(#3#7+^G'Shutting down for System Event.'^G); + nl; + hangup:=TRUE; + end; + if ((not ch) and (nsl<0) and (useron) and (choptime=0.0)) then begin + nl; nl; + + printf('notleft'); + if (nofile) then + sprint(#3#7+'You have used up all your time. Time expired.'); + + if (thisuser.timebank<>0) then begin + nl; + sprint(#3#5+'Your Time Bank account has '+ + #3#3+cstr(thisuser.timebank)+#3#5+' minutes left in it.'); + dyny:=TRUE; + if pynq('Withdraw from Time Bank? [Y] : ') then begin + prt('Withdraw how many minutes? '); inu(zz); lng:=zz; + if (lng>0) then begin + if lng>thisuser.timebank then lng:=thisuser.timebank; + dec(thisuser.timebankadd,lng); + if (thisuser.timebankadd<0) then thisuser.timebankadd:=0; + dec(thisuser.timebank,lng); + inc(thisuser.tltoday,lng); + sprint('^5In your account: ^3'+cstr(thisuser.timebank)+ + '^5 Time left online: ^3'+cstr(trunc(nsl) div 60)); + sysoplog('TimeBank: Time expired, withdrew '+cstrl(lng)+' minutes.'); + end; + end else + sprint(#3#7+'Hanging up.'); + end; + if (nsl<0) then hangup:=TRUE; + end; + checkhangup; + sde; +end; + +procedure gp(i,j:integer); +var x:integer; +begin + case j of + 0:gotoxy(58,8); + 1:gotoxy(20,7); 2:gotoxy(20,8); 3:gotoxy(20,9); + 4:gotoxy(20,10); 5:gotoxy(36,7); 6:gotoxy(36,8); + end; + if (j in [1..4]) then x:=5 else x:=3; + if (i=2) then inc(x); + if (i>0) then gotoxy(wherex+x,wherey); +end; + +procedure changeuserdatawindow; +var wind:windowrec; + s:string[39]; + oo,i,oldsl,{realsl,realdsl,}savsl,savdsl:integer; + c:char; + sx,sy,ta:byte; + done,done1:boolean; + + procedure shd(i:integer; b:boolean); + var j:integer; + c:char; + begin + gp(0,i); + if (b) then textcolor(14) else textcolor(9); + case i of + 1:write('SL :'); 2:write('DSL :'); 3:write('FP :'); + 4:write('Note:'); 5:write('AR:'); 6:write('AC:'); + end; + if (b) then begin textcolor(0); textbackground(7); end else textcolor(14); + write(' '); + with thisuser do + case i of + 0:if (b) then write('ÄDoneÄ') + else begin + textcolor(9); write('Ä'); + textcolor(11); write('Done'); + textcolor(9); write('Ä'); + end; + 1:write(mln(cstr(sl),3)); + 2:write(mln(cstr(dsl),3)); + 3:write(mln(cstrl(filepoints),5)); + 4:write(mln(note,39)); + 5:for c:='A' to 'Z' do begin + if (c in ar) then textcolor(4) + else if (b) then textcolor(0) else textcolor(7); + write(c); + end; + 6:if (b) then cpr($07,$70,thisuser) else cpr($70,$07,thisuser); + end; + write(' '); + textbackground(0); + cursoron(i in [1..4]); + + if (b) then begin + gotoxy(26,12); textcolor(14); + for j:=1 to 41 do write(' '); + gotoxy(26,12); + case i of + 0:write('Done - exit back to BBS'); + 1:write('Security Level (0..255)'); + 2:write('Download Security Level (0..255)'); + 3:write('File Points'); + 4:write('Special SysOp note for this user'); + 5:write('Special access flags ("!" to toggle all)'); + 6:write('Restrictions & special ("!" to clear)'); + end; + end; + end; + + procedure ddwind; + var i:integer; + c:char; + begin + cursoron(FALSE); + textcolor(9); + box(1,18,6,68,13); window(19,7,67,12); clrscr; + box(1,18,6,68,11); window(19,7,67,10); + + window(1,1,80,25); + gotoxy(20,12); textcolor(9); write('Desc:'); + + for i:=0 to 6 do shd(i,FALSE); + + shd(oo,TRUE); + end; + + procedure ar_tog(c:char); + begin + if (c in thisuser.ar) then thisuser.ar:=thisuser.ar-[c] + else thisuser.ar:=thisuser.ar+[c]; + end; + +begin + saveuf; +{ + if ((realsl<>-1) and (realdsl<>-1)) then begin + savsl:=thisuser.sl; savdsl:=thisuser.dsl; + thisuser.sl:=realsl; thisuser.dsl:=realdsl; + saveuf; + thisuser.sl:=savsl; thisuser.dsl:=savdsl; + end;} + + infield_out_fgrd:=0; + infield_out_bkgd:=7; + infield_inp_fgrd:=0; + infield_inp_bkgd:=7; + infield_arrow_exit:=TRUE; + infield_arrow_exited:=FALSE; + + sx:=wherex; sy:=wherey; ta:=textattr; + savescreen(wind,18,6,68,13); + oo:=1; + + ddwind; + done:=FALSE; + repeat + infield_arrow_exited:=FALSE; + case oo of + 0:begin + done1:=FALSE; + shd(oo,TRUE); + repeat + c:=readkey; + case upcase(c) of + ^M:begin done:=TRUE; done1:=TRUE; end; + #0:begin + c:=readkey; + case ord(c) of + ARROW_DOWN,ARROW_UP: + begin + infield_arrow_exited:=TRUE; + infield_last_arrow:=ord(c); + done1:=TRUE; + end; + end; + end; + end; + until (done1); + end; + 1:begin + s:=cstr(thisuser.sl); infield1(26,7,s,3); + if (value(s)<>thisuser.sl) then begin + realsl:=value(s); + thisuser.sl:=value(s); + inc(thisuser.tltoday, + systat.timeallow[thisuser.sl]-systat.timeallow[realsl]); + end; + end; + 2:begin + s:=cstr(thisuser.dsl); infield1(26,8,s,3); + if (value(s)<>thisuser.dsl) then begin + realdsl:=value(s); + thisuser.dsl:=value(s); + end; + end; + 3:begin + s:=cstr(thisuser.filepoints); infield1(26,9,s,5); + thisuser.filepoints:=value(s); + end; + 4:begin + s:=thisuser.note; infield1(26,10,s,39); + thisuser.note:=s; + end; + 5:begin + done1:=FALSE; + repeat + c:=upcase(readkey); + case c of + #13:done1:=TRUE; + #0:begin + c:=readkey; + case ord(c) of + ARROW_DOWN,ARROW_UP: + begin + infield_arrow_exited:=TRUE; + infield_last_arrow:=ord(c); + done1:=TRUE; + end; + end; + end; + '!':begin + for c:='A' to 'Z' do ar_tog(c); + shd(oo,TRUE); + end; + 'A'..'Z':begin ar_tog(c); shd(oo,TRUE); end; + end; + until (done1); + end; + 6:begin + s:='LCVBA*PEKM1234'; + done1:=FALSE; + repeat + c:=upcase(readkey); + if (c=#13) then done1:=TRUE + else + if (c=#0) then begin + c:=readkey; + case ord(c) of + ARROW_DOWN,ARROW_UP: + begin + infield_arrow_exited:=TRUE; + infield_last_arrow:=ord(c); + done1:=TRUE; + end; + end; + end + else + if (pos(c,s)<>0) then begin + acch(c,thisuser); + shd(oo,TRUE); + end + else begin + if (c='!') then + for i:=1 to length(s) do setacch(s[i],FALSE,thisuser); + shd(oo,TRUE); + end; + until (done1); + end; + end; + if (not infield_arrow_exited) then begin + infield_arrow_exited:=TRUE; + infield_last_arrow:=ARROW_DOWN; + end; + if (infield_arrow_exited) then + case infield_last_arrow of + ARROW_DOWN,ARROW_UP:begin + shd(oo,FALSE); + if (infield_last_arrow=ARROW_DOWN) then begin + inc(oo); + if (oo>6) then oo:=0; + end else begin + dec(oo); + if (oo<0) then oo:=6; + end; + shd(oo,TRUE); + end; + end; + until (done); + + removewindow(wind); topscr; + gotoxy(sx,sy); textattr:=ta; + cursoron(TRUE); + if (systat.compressbases) then newcomptables; + + saveuf; + +{ if ((realsl<>-1) and (realdsl<>-1)) then begin + savsl:=thisuser.sl; savdsl:=thisuser.dsl; + thisuser.sl:=realsl; thisuser.dsl:=realdsl; + saveuf; + thisuser.sl:=savsl; thisuser.dsl:=savdsl; + end;} +end; + +procedure readinmacros; +var macrf:file of macrorec; + i:integer; +begin + for i:=1 to 4 do macros.macro[i]:=''; + if (thisuser.mpointer<>-1) then begin + assign(macrf,systat.gfilepath+'macro.lst'); + {$I-} reset(macrf); {$I+} + if (ioresult<>0) then begin + sysoplog('!!! "MACRO.LST" file not found. Created.'); + rewrite(macrf); close(macrf); reset(macrf); + end; + if (filesize(macrf)>thisuser.mpointer) then begin + seek(macrf,thisuser.mpointer); + read(macrf,macros); + end else + thisuser.mpointer:=-1; + close(macrf); + end; +end; + +procedure saveuf; +var savsl,savdsl:integer; + ufo:boolean; +begin + if ((realsl<>-1) and (realdsl<>-1)) then begin + savsl:=thisuser.sl; savdsl:=thisuser.dsl; + thisuser.sl:=realsl; thisuser.dsl:=realdsl; + + ufo:=(filerec(uf).mode<>fmclosed); + if (not ufo) then reset(uf); + seek(uf,usernum); write(uf,thisuser); + if (not ufo) then close(uf); + + thisuser.sl:=savsl; thisuser.dsl:=savdsl; + end; +end; + +end. diff --git a/common3.pas b/common3.pas new file mode 100644 index 0000000..80814cb --- /dev/null +++ b/common3.pas @@ -0,0 +1,274 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit common3; + +interface + +uses + crt, dos, + myio, + tmpcom; + +procedure inu(var i:integer); +procedure ini(var i:byte); +procedure inputwn1(var v:string; l:integer; flags:string; var changed:boolean); +procedure inputwn(var v:string; l:integer; var changed:boolean); +procedure inputwnwc(var v:string; l:integer; var changed:boolean); +procedure inputmain(var s:string; ml:integer; flags:string); +procedure inputwc(var s:string; ml:integer); +procedure input(var s:string; ml:integer); +procedure inputl(var s:string; ml:integer); +procedure inputcaps(var s:string; ml:integer); +procedure mmkey(var s:string); + +implementation + +uses + common, common1, common2; + +procedure inu(var i:integer); +var s:string[5]; +begin + badini:=FALSE; + input(s,5); i:=value(s); + if (s='') then badini:=TRUE; +end; + +procedure ini(var i:byte); +var s:string[3]; +begin + badini:=FALSE; + input(s,3); i:=value(s); + if s='' then badini:=TRUE; +end; + +procedure inputwn1(var v:string; l:integer; flags:string; var changed:boolean); +var s,os:string; +begin + os:=v; + inputmain(s,l,flags); + if (s=' ') then + if pynq('Set to NULL string? ') then v:='' else + begin + end + else if (s<>'') then v:=s; + if (os<>v) then changed:=TRUE; +end; + +procedure inputwn(var v:string; l:integer; var changed:boolean); +begin + inputwn1(v,l,'',changed); +end; + +procedure inputwnwc(var v:string; l:integer; var changed:boolean); +begin + inputwn1(v,l,'c',changed); +end; + +(* flags: "U" - Uppercase only + "C" - Colors allowed + "L" - Linefeeds OFF - no linefeed after pressed + "D" - Display old if no change + "P" - Capitalize characters ("ERIC OMAN" --> "Eric Oman") +*) +procedure inputmain(var s:string; ml:integer; flags:string); +var os:string; + cp:integer; + c:char; + origcolor:byte; + xxupperonly,xxcolor,xxnolf,xxredisp,xxcaps:boolean; + + procedure dobackspace; + var i:integer; + c:byte; + begin + if (cp>1) then begin + dec(cp); + if (s[cp] in [#32..#255]) then begin + outkey(^H); outkey(' '); outkey(^H); + if (trapping) then write(trapfile,^H' '^H); + if (pap>0) then dec(pap); + end else begin + dec(pap); + if (cp>1) then + if (not (s[cp-1] in [#32..#255])) then begin + dec(cp); dec(pap); + if (s[cp]=#3) then begin + c:=origcolor; + i:=1; + while (i<=cp-1) do begin + if (s[i]=#3) then begin + c:=thisuser.cols[color in thisuser.ac][ord(s[i+1])]; + inc(i); + end; + inc(i); + end; + setc(c); + end; + end; + end; + end; + end; + +begin + flags:=allcaps(flags); + xxupperonly:=(pos('U',flags)<>0); xxcolor:=(pos('C',flags)<>0); + xxnolf:=(pos('L',flags)<>0); xxredisp:=(pos('D',flags)<>0); + xxcaps:=(pos('P',flags)<>0); + origcolor:=curco; os:=s; + + checkhangup; + if (hangup) then exit; + cp:=1; + repeat + getkey(c); + if (xxupperonly) then c:=upcase(c); + if (xxcaps) then + if (cp>1) then begin + if (c in ['A'..'Z','a'..'z']) then + if (s[cp-1] in ['A'..'Z','a'..'z']) then begin + if (c in ['A'..'Z']) then c:=chr(ord(c)+32); + end else + if (c in ['a'..'z']) then c:=chr(ord(c)-32); + end else + c:=upcase(c); + if (c in [#32..#255]) then + if (cp<=ml) then begin + s[cp]:=c; inc(cp); inc(pap); outkey(c); + if (trapping) then write(trapfile,c); + end else + begin + end + else case c of + ^H:dobackspace; + ^P:if ((xxcolor) and (cp<=ml-1)) then begin + getkey(c); + if (c in ['0'..'9']) then begin + cl(ord(c)-48); + s[cp]:=#3; s[cp+1]:=chr(ord(c)-48); + inc(cp,2); + end; + end; + ^X:while (cp<>1) do dobackspace; + end; + until ((c=^M) or (c=^N) or (hangup)); + s[0]:=chr(cp-1); + if ((xxredisp) and (s='')) then begin + s:=os; + prompt(s); + end; + if (not xxnolf) then nl; +end; + +procedure inputwc(var s:string; ml:integer); + begin inputmain(s,ml,'c'); end; + +procedure input(var s:string; ml:integer); + begin inputmain(s,ml,'u'); end; + +procedure inputl(var s:string; ml:integer); + begin inputmain(s,ml,''); end; + +procedure inputcaps(var s:string; ml:integer); + begin inputmain(s,ml,'p'); end; + +procedure mmkey(var s:string); +var s1:string; + i,newarea:integer; + c,cc:char; + achange,bb:boolean; +begin + s:=''; + if (buf<>'') then + if (copy(buf,1,1)='`') then begin + buf:=copy(buf,2,length(buf)-1); + i:=pos('`',buf); + if (i<>0) then begin + s:=allcaps(copy(buf,1,i-1)); + buf:=copy(buf,i+1,length(buf)-i); + nl; + exit; + end; + end; + + if (not (onekey in thisuser.ac)) then + input(s,60) + else + repeat + achange:=FALSE; + repeat + getkey(c); c:=upcase(c); + until ((c in [^H,^M,#32..#255]) or (hangup)); + if (c<>^H) then begin + outkey(c); + if (trapping) then write(trapfile,c); + inc(pap); + end; + if (c='/') then begin + s:=c; + repeat + getkey(c); c:=upcase(c); + until (c in [^H,^M,#32..#255]) or (hangup); + if (c<>^M) then begin + case c of + #225:bb:=bb; {* do nothing *} + else + begin + outkey(c); + if (trapping) then write(trapfile,c); + end; + end; + inc(pap); + end else + nl; + if (c in [^H,#127]) then prompt(' '+c); + if (c in ['/',#225]) then begin + bb:=systat.localsec; + cc:=fstring.echoc; + if (c=#225) then begin + systat.localsec:=TRUE; + fstring.echoc:=' '; + echo:=FALSE; + end; + cl(6); input(s,60); + systat.localsec:=bb; + fstring.echoc:=cc; + echo:=TRUE; + end else + if (not (c in [^H,#127,^M])) then begin s:=s+c; nl; end; + end else + if (c=';') then begin + input(s,60); + s:=c+s; + end else + if (c in ['0'..'9']) and ((fqarea) or (mqarea)) then begin + s:=c; getkey(c); + if (c in ['0'..'9']) then begin + print(c); + s:=s+c; + end; + if (c=^M) then nl; + if (c in [^H,#127]) then prompt(c+' '+c); + end else + if (c=^M) then nl + else + if (c<>^H) then begin + s:=c; + nl; + end; + until (not (c in [^H,#127])) or (hangup); + if (pos(';',s)<>0) then {* "command macros" *} + if (copy(s,1,2)<>'\\') then begin + if (onekey in thisuser.ac) then begin + s1:=copy(s,2,length(s)-1); + if (copy(s1,1,1)='/') then s:=copy(s1,1,2) else s:=copy(s1,1,1); + s1:=copy(s1,length(s)+1,length(s1)-length(s)); + end else begin + s1:=copy(s,pos(';',s)+1,length(s)-pos(';',s)); + s:=copy(s,1,pos(';',s)-1); + end; + while (pos(';',s1)<>0) do s1[pos(';',s1)]:=^M; + dm(' '+s1,c); + end; +end; + +end. diff --git a/conv17a.pas b/conv17a.pas new file mode 100644 index 0000000..83c34c5 --- /dev/null +++ b/conv17a.pas @@ -0,0 +1,969 @@ +{$B+} { Boolean complete evaluation on } +{$F+} { Far calls on } +{$I+} { I/O checking off } +{$N-} { No numeric coprocessor } +{$R-} { Range checking off } +{$S+} { Stack checking off } +{$V-} { Var-checking off } + +{$M 50000,0,90000} { Declared here suffices for all Units as well! } + +uses + crt,dos, + myio; + +const + needconv = 'S'; + +{rcg11172000 hmm...don't have this file...} +{I rcc16e2.pas} + +{$I rec17a.pas} +{$I rcc17a.pas} + +var + a,b,lastss,mp,gp,sp:astr; + h,i,j,k,savx,savy:integer; + c:char; + aw:boolean; { author working } + back:boolean; { converting BACK TO PREVIOUS VERSION ! .. } + found:boolean; + dirinfo:searchrec; + ptsforisrequest,ptsfornotval:integer; + wind:windowrec; + didit:boolean; + needs:longint; + + artable:astr; + + systatf1:file of systatrec1; + systat1:systatrec1; + systatf0:file of systatrec; + systat0:systatrec; + systatf:file of systatrec; + systat:systatrec; + + sf1:file of smalrec1; + sr1:smalrec1; + sf:file of smalrec; + sr:smalrec; + + uf1:file of userrec1; + user1:userrec1; {**} + uf0:file of userrec; + user0:userrec; + uf:file of userrec; + user:userrec; {**} + + bf1:file of boardrec1; + brd1:boardrec1; + bf:file of boardrec; + brd:boardrec; + + mailfile1:file of mailrec1; + mail1:mailrec1; {**} + mailfile:file of mailrec; + mail:mailrec; {**} + + ulf1:file of ulrec1; + ubrd1:ulrec1; + ulf:file of ulrec; + ubrd:ulrec; + + ulff1:file of ulfrec1; + uld1:ulfrec1; + ulff:file of ulfrec; + uld:ulfrec; + +{ slf1:file of slr1; + seclev1:array[0..255] of slr1; + slf:file of seclevrec; + seclev:seclevrec;} + + gfilef1:file of gft1; {**} + gfile1:gft1; {**} + gfilef:file of gft; {**} + gfile:gft; {**} + + smf1:file of smr1; + sm1:smr1; + smf:file of smr; + sm:smr; + + ztf1:file of zlogt1; {**} + zt1:zlogt1; {**} + ztf:file of zlogt; {**} + zt:zlogt; {**} + + vdf1:file of vdatar1; {**} + vd1:vdatar1; {**} + vdf:file of vdatar; {**} + vd:vdatar; {**} + + macrf:file of macrorec; + macr:macrorec; + + xp1:file of expro1; + xp:file of expro; + xpr1:expro1; + xpr:expro; + + ff:file; + + {**} (* NOT defined globally in COMMON.PAS .... *) + +function value(I:astr):integer; +var n,n1:integer; +begin + val(i,n,n1); + if n1<>0 then begin + i:=copy(i,1,n1-1); + val(i,n,n1) + end; + value:=n; + if i='' then value:=0; +end; + +function cstrl(li:longint):astr; +var c:astr; +begin + str(li,c); + cstrl:=c; +end; + +function cstr(i:integer):astr; +var c:astr; +begin + str(i,c); + cstr:=c; +end; + + + +function tch(i:astr):astr; +begin + if length(i)>2 then i:=copy(i,length(i)-1,2) else + if length(i)=1 then i:='0'+i; + tch:=i; +end; + +function time:astr; +var reg:registers; + h,m,s:string[4]; +begin + reg.ax:=$2c00; intr($21,Dos.Registers(reg)); + str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s); + time:=tch(h)+':'+tch(m)+':'+tch(s); +end; + +function date:astr; +var reg:registers; + m,d,y:string[4]; +begin + reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y); str(reg.dx mod 256,d); + str(reg.dx shr 8,m); + date:=tch(m)+'/'+tch(d)+'/'+tch(y); +end; + +function leapyear(yr:integer):boolean; +begin + leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0)); +end; + +function days(mo,yr:integer):integer; +var d:integer; +begin + d:=value(copy('312831303130313130313031',1+(mo-1)*2,2)); + if (mo=2) and leapyear(yr) then d:=d+1; + days:=d; +end; + +function daycount(mo,yr:integer):integer; +var m,t:integer; +begin + t:=0; + for m:=1 to (mo-1) do t:=t+days(m,yr); + daycount:=t; +end; + +function daynum(dt:astr):integer; +var d,m,y,t,c:integer; +begin + t:=0; + m:=value(copy(dt,1,2)); + d:=value(copy(dt,4,2)); + y:=value(copy(dt,7,2))+1900; + for c:=1985 to y-1 do + if leapyear(c) then t:=t+366 else t:=t+365; + t:=t+daycount(m,y)+(d-1); + daynum:=t; + if y<1985 then daynum:=0; +end; + + +function freek(d:integer):longint; (* See disk space *) +{var r:registers;} +begin + freek:=diskfree(d) div 1024; +{ r.ax:=$3600; + r.dx:=d; + msdos(dos.registers(r)); + freek:=trunc(1.0*r.bx*r.ax*r.cx/1024.0);} +end; + +procedure tc(i:integer); +begin + textcolor(i); +end; + +procedure star(s:astr); +begin + tc(9); write('þ '); + tc(11); writeln(s); +end; + +function exdrv(s:astr):byte; +begin + s:=fexpand(s); + exdrv:=ord(s[1])-64; +end; + +procedure movefile(srcname,destpath:string); +var buffer:array[1..16384] of byte; + dfs,nrec:integer; + src,dest:file; + dd,dn,de:string; + + procedure dodate; + var r:registers; + od,ot,ha:integer; + begin + srcname:=srcname+#0; + destpath:=destpath+#0; + with r do begin + ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5700; msdos(dos.registers(r)); + od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(dos.registers(r)); + ax:=$3d02; ds:=seg(destpath[1]); dx:=ofs(destpath[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(dos.registers(r)); + ax:=$3e00; bx:=ha; msdos(dos.registers(r)); + end; + end; + +begin + fsplit(srcname,dd,dn,de); + destpath:=destpath+dn+de; + assign(src,srcname); + {$I-} reset(src,1); {$I+} + if (ioresult<>0) then begin + writeln; + star('"'+srcname+'": File not found.'^G^G); +{ halt(1);} + end else begin + dfs:=freek(exdrv(destpath)); + + {rcg11172000 don't have LONGfilesize()...} + {if (trunc(longfilesize(src)/1024.0)+1>=dfs) then begin} + + if (trunc(filesize(src)/1024.0)+1>=dfs) then begin + writeln; + star('"'+srcname+'": Disk full.'); + halt(1); + end else begin + assign(dest,destpath); rewrite(dest,1); + repeat + blockread(src,buffer,16384,nrec); + blockwrite(dest,buffer,nrec); + until (nrec<16384); + close(dest); + close(src); + dodate; + erase(src); + end; + end; +end; + +procedure smovefile(srcname,destpath:string); +begin + star('Moving "'+srcname+'" to "'+destpath+'"'); + movefile(srcname,destpath); +end; + +procedure ffile(fn:astr); +begin + findfirst(fn,anyfile,dirinfo); + found:=(doserror=0); +end; + +procedure nfile; +var r:registers; +begin + findnext(dirinfo); + found:=(doserror=0); +end; + +function allcaps(s:astr):astr; (* returns a COMPLETELY capitalized string *) +var i:integer; +begin + for i:=1 to length(s) do + s[i]:=upcase(s[i]); + allcaps:=s; +end; + +procedure cursoron; +var reg:registers; +begin + with reg do begin + ch:=07; cl:=08; ah:=1; + intr($10,reg); + end; +end; + +procedure cursoroff; +var reg:registers; +begin + with reg do begin + ch:=09; cl:=00; ah:=1; + intr($10,reg); + end; +end; + +procedure prt(s:string); +begin + textcolor(9); write(s); +end; + +procedure ttl(s:string); +begin + writeln; + textcolor(9); write('ÄÄ['); + textbackground(1); textcolor(15); + write(' '+s+' '); + textbackground(0); textcolor(9); + write(']'); + repeat write('Ä') until wherex=80; + writeln; +end; + +procedure ee(s:astr); +begin + clrscr; + writeln; + tc(4); writeln('ERROR:'); + writeln; + tc(15); write(' '+s); + writeln; + writeln; + tc(9); write('Hit any key to exit : '); + repeat until keypressed; + c:=readkey; + removewindow(wind); gotoxy(savx,savy); + halt(1); +end; + +procedure ss(s:astr); +begin + lastss:=allcaps(s); + star('Searching for "'+lastss+'"'); +end; + +procedure cantopen; +begin + ee('Unable to open "'+lastss+'"'); +end; + +function needc(c:char):boolean; +begin + if pos(c,needconv)<>0 then needc:=TRUE else needc:=FALSE; +end; + +procedure fvers; +var i:integer; +begin + needs:=0; + + writeln; + ss('status.dat'); + assign(systatf0,'status.dat'); + {$I-} reset(systatf0); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(systatf0,systat0); {$I+} + if (ioresult<>0) then begin + close(systatf0); + assign(systatf,'status.dat'); + reset(systatf); + {$I-} read(systatf,systat); {$I+} + gp:=systat.gfilepath; + mp:=systat.menupath; + close(systatf); + end else begin + gp:=systat0.gfilepath; + mp:=systat0.menupath; + close(systatf0); + end; + inc(needs,sizeof(systatrec)); + + if needc('1') then begin + ss('names.lst'); + assign(sf1,gp+'names.lst'); + {$I-} reset(sf1); {$I+} + if (ioresult<>0) then begin + assign(systatf,'status.dat'); + reset(systatf); + {$I-} read(systatf,systat); {$I+} + gp:=systat.gfilepath; + mp:=systat.menupath; + close(systatf); + assign(sf1,gp+'names.lst'); + {$I-} reset(sf1); {$I+} + if (ioresult<>0) then cantopen; + end; + {$I-} read(sf1,sr1); {$I+} + inc(needs,sizeof(smalrec)*filesize(sf1)); + close(sf1); + end; + + if needc('2') then begin + ss('user.lst'); + assign(uf1,gp+'user.lst'); + {$I-} reset(uf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(uf1,user1); {$I+} + inc(needs,sizeof(userrec)*filesize(uf1)); + close(uf1); + end; + + if needc('3') then begin + ss('boards.dat'); + assign(bf1,gp+'boards.dat'); + {$I-} reset(bf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(bf1,brd1); {$I+} + inc(needs,sizeof(boardrec)*filesize(bf1)); + close(bf1); + end; + + if needc('4') then begin + ss('email.dat'); + assign(mailfile1,gp+'email.dat'); + {$I-} reset(mailfile1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(mailfile1,mail1); {$I+} + inc(needs,sizeof(mailrec)*filesize(mailfile1)); + close(mailfile1); + end; + + if needc('5') then begin + ss('gfiles.dat'); + assign(gfilef1,gp+'gfiles.dat'); + {$I-} reset(gfilef1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(gfilef1,gfile1); {$I+} + inc(needs,sizeof(gft)*filesize(gfilef1)); + close(gfilef1); + end; + + if needc('6') then begin + ss('protocol.dat'); + assign(xp1,gp+'protocol.dat'); + {$I-} reset(xp1); {$I+} + if (ioresult<>0) then cantopen; + inc(needs,sizeof(expro)*filesize(xp1)); + close(xp1); + end; + + if needc('7') then begin + ss('shortmsg.dat'); + assign(smf1,gp+'shortmsg.dat'); + {$I-} reset(smf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(smf1,sm1); {$I+} + inc(needs,sizeof(smalrec)*filesize(smf1)); + close(smf1); + end; + + if needc('8') then begin + ss('uploads.dat'); + assign(ulf1,gp+'uploads.dat'); + {$I-} reset(ulf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(ulf1,ubrd1); {$I+} + inc(needs,sizeof(ulrec)*filesize(ulf1)); + close(ulf1); + end; + + if needc('9') then begin + ss('voting.dat'); + assign(vdf1,gp+'voting.dat'); + {$I-} reset(vdf1); {$I+} + inc(needs,sizeof(vdatar)*filesize(vdf1)); + if (ioresult=0) then close(vdf1); + end; + + if needc('A') then begin + ss('zlog.dat'); + assign(ztf1,gp+'zlog.dat'); + {$I-} reset(ztf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(ztf1,zt1); {$I+} + inc(needs,sizeof(zlogt)*filesize(ztf1)); + close(ztf1); + end; + + if needc('B') then begin + ss('*.dir'); + ffile(gp+'*.dir'); + while (found) do begin + assign(ulff1,fexpand(gp+dirinfo.name)); + {$I-} reset(ulff1); {$I+} + inc(needs,sizeof(ulfrec)*filesize(ulff1)); + close(ulff1); + nfile; + end; + end; +end; + +function barconv(c:char):char; +var s:astr; +begin + if (pos(c,artable)<>0) then s:=copy('ABCDEFG',pos(c,artable),1) else s:='@'; + barconv:=s[1]; +end; + +function arconv(c:char):char; +begin + if (c in ['A'..'G']) then + if (length(artable)>=ord(c)-64) and (artable[ord(c)-64] in ['@'..'Z']) then + arconv:=artable[ord(c)-64] + else arconv:='@' + else arconv:='@'; +end; + +{rcg11172000 had to change this to get it compiling under Free Pascal...} +{function substall(src,old,new:astr):astr;} +function substall(src,old,_new:astr):astr; +var p:integer; +begin + p:=1; + while (p>0) do begin + p:=pos(old,src); + if (p>0) then begin + insert(_new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substall:=src; +end; + +procedure bconvert(xx:integer); +var i,j,k:integer; + s:astr; + b:boolean; +begin +end; + +procedure fconvert(xx:integer); +const dcols:clrs=((15,7,7,15,15,15,112,7,143,7),(15,3,1,11,9,14,31,4,140,10)); +var i,j,k:integer; + b:boolean; + s,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15:astr; + c:char; + mf,mf1:text; + sepmsgs,nocopy:boolean; + f:file; + mary:array[0..200] of messagerec; + curdir:astr; + newpath:array[1..3] of astr; + + procedure make_paths; + var s:string; + i,j:integer; + begin + for i:=1 to 3 do begin + while copy(newpath[i],length(newpath[i]),1)='\' do + newpath[i]:=copy(newpath[i],1,length(newpath[i])-1); + case i of 1:s:='AFILES'; 2:s:='TRAP'; 3:s:='TEMP'; end; + star(s+' path ("'+fexpand(newpath[i])+'")'); + {$I-} mkdir(fexpand(newpath[i])); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(newpath[i])+'"'); + halt(1); + end; + if (i=3) then + for j:=1 to 3 do begin + {$I-} mkdir(fexpand(newpath[i]+'\'+cstr(j))); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(newpath[i]+'\'+cstr(j))+'"'); + halt(1); + end; + end; + newpath[i]:=newpath[i]+'\'; + end; + end; + +begin + case xx of + 0:begin + ttl('PATCHING "STATUS.DAT" - No conversion necessary'); + ffile('status.dat'); + if not found then star('STATUS.DAT not found.') + else begin + assign(systatf0,'status.old'); + rewrite(systatf0); + close(systatf0); + erase(systatf0); + assign(systatf0,'status.dat'); + rename(systatf0,'status.old'); + reset(systatf0); + assign(systatf,'status.dat'); + rewrite(systatf); + seek(systatf0,0); read(systatf0,systat0); + systat:=systat0; + with systat do begin + hangup:='~~~'^A^A^A'~~~ATH0'^M; + offhook:='ATH1M0'^M; + answer:=answer+^M; + if (length(init)=40) then init:=copy(init,1,39); + init:=init+^M; + + for i:=1 to 140 do res[i]:=0; + end; + seek(systatf,0); write(systatf,systat); + close(systatf); + close(systatf0); + end; + end; +(* + 2:begin + ttl('PATCHING "USER.LST" - No conversion necessary'); + chdir(copy(gp,1,length(gp)-1)); + ffile('user.lst'); + if not found then star('USER.LST not found.') + else begin + assign(uf0,'user.old'); + rewrite(uf0); + close(uf0); + erase(uf0); + assign(uf0,'user.lst'); + rename(uf0,'user.old'); + reset(uf0); + assign(uf1,'user.old'); + reset(uf1); + assign(uf,'user.lst'); + rewrite(uf); + for i:=0 to filesize(uf0)-1 do begin + seek(uf0,i); read(uf0,user0); + seek(uf1,i); read(uf1,user1); + star(' (record #'+cstr(i)+' of '+cstr(filesize(uf0)-1)+')'); gotoxy(1,wherey-1); + user:=user0; + + user.ttimeon:=round(user1.ttimeon); + user.uk:=round(user1.uk); + user.dk:=round(user1.dk); + user.credit:=round(user1.credit); + + user.chatauto:=FALSE; + user.chatseperate:=FALSE; + + seek(uf,i); write(uf,user); + end; + close(uf0); + close(uf); + writeln; + end; + chdir(sp); + end; + 10:begin + ttl('Converting "ZLOG.DAT'); + chdir(copy(gp,1,length(gp)-1)); + ffile('zlog.dat'); + if (not found) then star('ZLOG.DAT not found.') + else begin + assign(ztf1,'zlog.old'); + rewrite(ztf1); + close(ztf1); + erase(ztf1); + assign(ztf1,'zlog.dat'); + rename(ztf1,'zlog.old'); + reset(ztf1); + assign(ztf,'zlog.dat'); + rewrite(ztf); + for i:=0 to filesize(ztf1)-1 do begin + seek(ztf1,i); read(ztf1,zt1); + star(' (record #'+cstr(i)+' of '+cstr(filesize(ztf1)-1)+')'); gotoxy(1,wherey-1); + + with zt do begin + date:=zt1.date; + for j:=0 to 4 do userbaud[j]:=0; + active:=zt1.active; + calls:=zt1.calls; + newusers:=0; + pubpost:=zt1.post; + privpost:=zt1.email; + fback:=zt1.fback; + criterr:=0; + uploads:=zt1.up; + downloads:=0; + uk:=0; + dk:=0; + end; + + seek(ztf,i); write(ztf,zt); + end; + close(ztf1); + close(ztf); + writeln; + end; + chdir(sp); + end; + 13:begin + ttl('Converting "*.MNU" menu files'); + chdir(copy(mp,1,length(mp)-1)); + ffile('*.mnu'); + if not found then star('No *.MNU files present.') + else begin + repeat + s:=dirinfo.name; + assign(mf1,copy(s,1,length(s)-3)+'OLD'); + rewrite(mf1); + close(mf1); + erase(mf1); + assign(mf1,s); + {$I-} rename(mf1,copy(s,1,length(s)-3)+'OLD'); {$I+} + if (ioresult<>0) then star('Error renaming "'+s+'" - Nothing done.') + else begin + assign(mf1,copy(s,1,length(s)-3)+'OLD'); + {$I-} reset(mf1); {$I+} + assign(mf,s); + {$I-} rewrite(mf); {$I+} + star('Converting "'+s+'"'); + + readln(mf1,s1); + readln(mf1,s2); + + s3:='T'; {* DEFAULT: auto-time display *} + if (copy(s2,1,1)='*') or (copy(s2,1,1)='!') or (copy(s2,1,1)='#') then begin + c:=s2[1]; + case c of + '*':s3:=''; + '!':s3:='H'; {* auto-help display *} + '#':s3:='HT'; {* auto-help and time display *} + end; + s2:=copy(s2,2,length(s2)-1); + end; + + writeln(mf,''); + writeln(mf,s1); writeln(mf,''); + writeln(mf,s2); + writeln(mf,'0'); writeln(mf,'@'); writeln(mf,''); + writeln(mf,'MAIN'); writeln(mf,'4'); + writeln(mf,'1'); writeln(mf,'3'); writeln(mf,'1'); + writeln(mf,s3); + + repeat + nocopy:=FALSE; + + readln(mf1,s1); {* command letters *} + readln(mf1,s2); {* SL requirement *} + readln(mf1,s3); {* Cmdkeys *} + readln(mf1,s4); {* MString *} + readln(mf1,s5); {* AR level *} + + if (not nocopy) then begin + writeln(mf,''); {* long description *} + writeln(mf,''); {* short description *} + writeln(mf,s1); {* command letters *} + writeln(mf,s2); {* security requirement *} + writeln(mf,s5); {* AR flag requirement *} + writeln(mf,s3); {* Cmdkeys *} + writeln(mf,s4); {* MString *} + writeln(mf,''); {* command flags *} + end; + + until (eof(mf1)); + + close(mf); + close(mf1); + rename(mf,copy(s,1,length(s)-3)+'TCP'); + end; + nfile; + until not found; + ffile('*.TCP'); + repeat + s:=dirinfo.name; + assign(mf,s); + rename(mf,copy(s,1,length(s)-3)+'MNU'); + nfile; + until not found; + end; + chdir(sp); + end; +*) + end; +end; + +procedure convert(xx:integer); +var i,j,k:integer; + s:astr; +begin + if back then bconvert(xx) else fconvert(xx); +end; + +begin + infield_out_fgrd:=15; + infield_out_bkgd:=1; + infield_inp_fgrd:=0; + infield_inp_bkgd:=7; + + getdir(0,sp); + aw:=FALSE; + didit:=FALSE; + if paramcount>0 then if allcaps(paramstr(1))='C' then aw:=TRUE; + savx:=wherex; savy:=wherey; + setwindow(wind,1,1,80,25,7,0,0); + clrscr; + textbackground(1); textcolor(15); clreol; + write('Telegard Conversion for '+ver1+' ¯¯¯¯¯¯¯¯¯ '+ver); + textbackground(0); + window(1,2,80,25); clrscr; + tc(14); + writeln; + writeln('This program is provided to add/modify/create files used by Telegard to'); + writeln('make it 100% functional under the '+ver+' environment. This file MUST'); + writeln('be ran in the directory in which STATUS.DAT is found, and STATUS.DAT MUST'); + writeln('be in '+ver1+' format!!! If STATUS.DAT is not in the current directory,'); + writeln('or if you have already ran this program (STATUS.DAT has already been'); + writeln('converted), this program will abort.'); + writeln; + tc(9); write('Hit any key to continue ( to abort NOW) : '); + repeat until keypressed; + c:=readkey; + if (c=#27) then ee('ABORTED CONVERSION'); + + repeat + clrscr; + fvers; + + if (not aw) then begin + writeln; + star('WARNING! This conversion program needs APPROXIMATELY'); + star(cstrl(needs)+' bytes free on your main BBS drive!!!!!!!!'); + writeln; + star('You currently have '+cstrl(freek(0)*1024)+' bytes left on the current drive.'); + writeln; + star('If you DO NOT have enough space left, your drive will probably'); + star('explode, and your house will burn to the ground. If you are'); + star('skeptical of this, feel free to call Garfield, SysOp of Electric'); + star('Eye ][ BBS (313/776-8928), who can tell you how bad HIS messed up'); + star('when he converted from 1.6d3 --> 1.6e1 with only 500k!'); + writeln; + if (not l_pynq('Proceed? ')) then ee('Aborted conversion'); + end; + + clrscr; + writeln; + if aw then begin + for i:=0 to 13 do begin + if (i>=1) and (i<=9) then c:=chr(i+48) else + if (i=0) then c:='S' else + if (i>=10) then c:=chr(i+55); + if needc(c) then begin + tc(9); write('['+cstr(i)+'] '); + if i<10 then write(' '); + tc(11); + case i of + 0:write('(S)tatus.dat'); + 1:write('names.lst'); + 2:write('user.lst'); + 3:write('boards.dat'); + 4:write('email.dat'); + 5:write('gfiles.dat'); + 6:write('protocol.dat'); + 7:write('shortmsg.dat'); + 8:write('uploads.dat'); + 9:write('voting.dat'); + 10:write('zlog.dat'); + 11:write(gp+'*.dir'); + 12:write(gp+'*.brd'); + 13:write(mp+'*.mnu'); + end; + writeln; + end; + end; + writeln; + tc(14); write('Enter # to convert, [A]ll or [Q]uit :'); + tc(9); readln(a); a:=allcaps(a); + + j:=value(a); + end + else a:='A'; + + if (j=0) then + if (copy(a,1,1)='S') then j:=0 else j:=-1; + + if (copy(a,1,1)<>'Q') or + ((j>=0) and (j<=13)) then begin + writeln; + if aw then begin + tc(14); write('[1]Convert to '+ver+' - [2]Convert back to '+ver1+' : '); + tc(9); readln(b); b:=allcaps(b); + h:=value(b); + end else h:=1; + + if (h in [1,2]) then begin + clrscr; tc(15); + back:=FALSE; + if h=2 then back:=TRUE; + if back then begin + tc(31); + writeln('Convert '+ver+' ¯¯¯¯¯¯¯¯¯ '+ver1); + end else + writeln('Convert '+ver1+' ¯¯¯¯¯¯¯¯¯ '+ver); + writeln; + tc(4); write('WARNING: '); + tc(12); + if back then writeln('If files are not in version '+ver+' format,') else + writeln('If files are NOT in version '+ver1+' format,'); + writeln('the data will be COMPLETELY LOST *FOREVER*!!'); + writeln; + writeln; + tc(14); writeln('ARE YOU ABSOLUTELY SURE?'); + writeln('(Enter "YES" in ALL CAPS, without quotes, if you are...)'); + write(':'); + readln(b); + + if b='YES' then begin + clrscr; + + if copy(a,1,1)<>'A' then convert(j) + else begin + for i:=0 to 13 do convert(i); +{ ttl('Moving new files into their directories'); + smovefile('protocol.dat',systat.gfilepath); + smovefile('sysfunc.ans',systat.afilepath);} + end; + didit:=TRUE; + end; + end; + end; + if not aw then a:='Q'; + until copy(a,1,1)='Q'; + + writeln; + star('Press any key...'); c:=readkey; + clrscr; + removewindow(wind); + + if didit then begin + setwindow(wind,20,11,59,17,9,1,1); + clrscr; tc(15); + gotoxy(4,3); + write('Thank you for choosing Telegard!'); + CursorOff; delay(1500); CursorOn; + removewindow(wind); + end; + gotoxy(savx,savy); + chdir(sp); +end. diff --git a/conv17a9.pas b/conv17a9.pas new file mode 100644 index 0000000..b59a52e --- /dev/null +++ b/conv17a9.pas @@ -0,0 +1,860 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +{$M 50000,0,1024} { Declared here suffices for all Units as well! } + +uses + crt,dos, + + {rcg11172000 No semicolon?} + {myio,} + + myio; + + +const + needconv = 'E'; + standard_conversion = FALSE; + +{$I rcc17a.pas} + +{rcg11172000 hmm...don't have this file...} +{I rec17b.pas} + +{$I brec17a2.pas} + +{rcg11172000 ...but need this...} +{$I recc.pas} + +var + a,b,lastss,mp,gp,sp:astr; + h,i,j,k,savx,savy:integer; + c:char; + aw:boolean; { author working } + back:boolean; { converting BACK TO PREVIOUS VERSION ! .. } + found:boolean; + dirinfo:searchrec; + ptsforisrequest,ptsfornotval:integer; + wind:windowrec; + didit:boolean; + needs:longint; + + artable:astr; + +{ systatf17a4:file of systatrec17a4;} +{ systat17a4:systatrec17a4;} + systatf1:file of systatrec1; + systat1:systatrec1; + systatf0:file of systatrec; + systat0:systatrec; + systatf:file of systatrec; + systat:systatrec; + + modemrf17a7:file of modemrec17a7; + modemr17a7:modemrec17a7; + modemrf:file of modemrec; + modemr:modemrec; + fstringf:file of fstringrec; + fstring:fstringrec; + + sf1:file of smalrec1; + sr1:smalrec1; + sf:file of smalrec; + sr:smalrec; + + uf1:file of userrec1; + user1:userrec1; {**} + uf0:file of userrec; + user0:userrec; + uf:file of userrec; + user:userrec; {**} + + bf1:file of boardrec1; + brd1:boardrec1; +{ bf17a5:file of boardrec17a5;} +{ brd17a5:boardrec17a5;} + bf:file of boardrec; + brd:boardrec; + + mailfile1:file of mailrec1; + mail1:mailrec1; {**} + mailfile:file of mailrec; + mail:mailrec; {**} + + ulf1:file of ulrec1; + ubrd1:ulrec1; +{ ulf17a2:file of ulrec17a2;} +{ ubrd17a2:ulrec17a2;} + ulf0:file of ulrec; + ubrd0:ulrec; + ulf:file of ulrec; + ubrd:ulrec; + + ulff1:file of ulfrec1; + uld1:ulfrec1; + ulff:file of ulfrec; + uld:ulfrec; + +{ slf1:file of slr1; + seclev1:array[0..255] of slr1; + slf:file of seclevrec; + seclev:seclevrec;} + + gfilef1:file of gft1; {**} + gfile1:gft1; {**} + gfilef:file of tfilerec;{**} + gfile:tfilerec; {**} + + smf1:file of smr1; + sm1:smr1; + smf:file of smr; + sm:smr; + + ztf1:file of zlogt1; {**} + zt1:zlogt1; {**} + ztf:file of zlogrec; {**} + zt:zlogrec; {**} + + vdf1:file of vdatar1; {**} + vd1:vdatar1; {**} + vdf:file of vdatar; {**} + vd:vdatar; {**} + + macrf:file of macrorec; + macr:macrorec; + + xp1:file of protrec1; + xpr1:protrec1; + xp0:file of protrec; + xpr0:protrec; + xp:file of protrec; + xpr:protrec; + + mbasef1:file of messagerec1; + mbase1:messagerec1; + mbasef:file of messagerec; + mbase:messagerec; + + ff:file; + + {**} (* NOT defined globally in COMMON.PAS .... *) + +function value(I:astr):integer; +var n,n1:integer; +begin + val(i,n,n1); + if n1<>0 then begin + i:=copy(i,1,n1-1); + val(i,n,n1) + end; + value:=n; + if i='' then value:=0; +end; + +function cstrl(li:longint):astr; +var c:astr; +begin + str(li,c); + cstrl:=c; +end; + +function cstr(i:integer):astr; +var c:astr; +begin + str(i,c); + cstr:=c; +end; + + + +function tch(i:astr):astr; +begin + if length(i)>2 then i:=copy(i,length(i)-1,2) else + if length(i)=1 then i:='0'+i; + tch:=i; +end; + +function time:astr; +var reg:registers; + h,m,s:string[4]; +begin + reg.ax:=$2c00; intr($21,Dos.Registers(reg)); + str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s); + time:=tch(h)+':'+tch(m)+':'+tch(s); +end; + +function date:astr; +var reg:registers; + m,d,y:string[4]; +begin + reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y); str(reg.dx mod 256,d); + str(reg.dx shr 8,m); + date:=tch(m)+'/'+tch(d)+'/'+tch(y); +end; + +function leapyear(yr:integer):boolean; +begin + leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0)); +end; + +function days(mo,yr:integer):integer; +var d:integer; +begin + d:=value(copy('312831303130313130313031',1+(mo-1)*2,2)); + if (mo=2) and leapyear(yr) then d:=d+1; + days:=d; +end; + +function daycount(mo,yr:integer):integer; +var m,t:integer; +begin + t:=0; + for m:=1 to (mo-1) do t:=t+days(m,yr); + daycount:=t; +end; + +function daynum(dt:astr):integer; +var d,m,y,t,c:integer; +begin + t:=0; + m:=value(copy(dt,1,2)); + d:=value(copy(dt,4,2)); + y:=value(copy(dt,7,2))+1900; + for c:=1985 to y-1 do + if leapyear(c) then t:=t+366 else t:=t+365; + t:=t+daycount(m,y)+(d-1); + daynum:=t; + if y<1985 then daynum:=0; +end; + + +function freek(d:integer):longint; (* See disk space *) +{var r:registers;} +begin + freek:=diskfree(d) div 1024; +{ r.ax:=$3600; + r.dx:=d; + msdos(dos.registers(r)); + freek:=trunc(1.0*r.bx*r.ax*r.cx/1024.0);} +end; + +procedure tc(i:integer); +begin + textcolor(i); +end; + +procedure star(s:astr); +begin + tc(9); write('þ '); + tc(11); writeln(s); +end; + +function exdrv(s:astr):byte; +begin + s:=fexpand(s); + exdrv:=ord(s[1])-64; +end; + +procedure movefile(srcname,destpath:string); +var buffer:array[1..16384] of byte; + dfs,nrec:integer; + src,dest:file; + dd,dn,de:string; + + procedure dodate; + var r:registers; + od,ot,ha:integer; + begin + srcname:=srcname+#0; + destpath:=destpath+#0; + with r do begin + ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5700; msdos(dos.registers(r)); + od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(dos.registers(r)); + ax:=$3d02; ds:=seg(destpath[1]); dx:=ofs(destpath[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(dos.registers(r)); + ax:=$3e00; bx:=ha; msdos(dos.registers(r)); + end; + end; + +begin + fsplit(srcname,dd,dn,de); + destpath:=destpath+dn+de; + assign(src,srcname); + {$I-} reset(src,1); {$I+} + if (ioresult<>0) then begin + writeln; + star('"'+srcname+'": File not found.'^G^G); +{ halt(1);} + end else begin + dfs:=freek(exdrv(destpath)); + + {rcg11172000 don't have LONGfilesize()...} + {if (trunc(longfilesize(src)/1024.0)+1>=dfs) then begin} + if (trunc(filesize(src)/1024.0)+1>=dfs) then begin + writeln; + star('"'+srcname+'": Disk full.'); + halt(1); + end else begin + assign(dest,destpath); rewrite(dest,1); + repeat + blockread(src,buffer,16384,nrec); + blockwrite(dest,buffer,nrec); + until (nrec<16384); + close(dest); + close(src); + dodate; + erase(src); + end; + end; +end; + +procedure smovefile(srcname,destpath:string); +begin + star('Moving "'+srcname+'" to "'+destpath+'"'); + movefile(srcname,destpath); +end; + +procedure ffile(fn:astr); +begin + findfirst(fn,anyfile,dirinfo); + found:=(doserror=0); +end; + +procedure nfile; +var r:registers; +begin + findnext(dirinfo); + found:=(doserror=0); +end; + +function allcaps(s:astr):astr; (* returns a COMPLETELY capitalized string *) +var i:integer; +begin + for i:=1 to length(s) do + s[i]:=upcase(s[i]); + allcaps:=s; +end; + +procedure cursoron; +var reg:registers; +begin + with reg do begin + ch:=07; cl:=08; ah:=1; + intr($10,reg); + end; +end; + +procedure cursoroff; +var reg:registers; +begin + with reg do begin + ch:=09; cl:=00; ah:=1; + intr($10,reg); + end; +end; + +procedure prt(s:string); +begin + textcolor(9); write(s); +end; + +procedure ttl(s:string); +begin + writeln; + textcolor(9); write('ÄÄ['); + textbackground(1); textcolor(15); + write(' '+s+' '); + textbackground(0); textcolor(9); + write(']'); + repeat write('Ä') until wherex=80; + writeln; +end; + +procedure ee(s:astr); +begin + clrscr; + writeln; + tc(4); writeln('ERROR:'); + writeln; + tc(15); write(' '+s); + writeln; + writeln; + tc(9); write('Hit any key to exit : '); + repeat until keypressed; + c:=readkey; + removewindow(wind); gotoxy(savx,savy); + halt(1); +end; + +procedure ss(s:astr); +begin + lastss:=allcaps(s); + star('Searching for "'+lastss+'"'); +end; + +procedure cantopen; +begin + ee('Unable to open "'+lastss+'"'); +end; + +function needc(c:char):boolean; +begin + if pos(c,needconv)<>0 then needc:=TRUE else needc:=FALSE; +end; + +procedure fvers; +var i:integer; +begin + needs:=0; + + writeln; + ss('status.dat'); + assign(systatf1,'status.dat'); + {$I-} reset(systatf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(systatf1,systat1); {$I+} + if (ioresult<>0) then begin + close(systatf1); + assign(systatf,'status.dat'); + reset(systatf); + {$I-} read(systatf,systat); {$I+} + gp:=systat.gfilepath; + mp:=systat.menupath; + close(systatf); + end else begin + gp:=systat1.gfilepath; + mp:=systat1.menupath; + close(systatf1); + end; + inc(needs,sizeof(systatrec)); + + if needc('1') then begin + ss('names.lst'); + assign(sf1,gp+'names.lst'); + {$I-} reset(sf1); {$I+} + if (ioresult<>0) then begin + assign(systatf,'status.dat'); + reset(systatf); + {$I-} read(systatf,systat); {$I+} + gp:=systat.gfilepath; + mp:=systat.menupath; + close(systatf); + assign(sf1,gp+'names.lst'); + {$I-} reset(sf1); {$I+} + if (ioresult<>0) then cantopen; + end; + {$I-} read(sf1,sr1); {$I+} + inc(needs,sizeof(smalrec)*filesize(sf1)); + close(sf1); + end; + + if needc('2') then begin + ss('user.lst'); + assign(uf1,gp+'user.lst'); + {$I-} reset(uf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(uf1,user1); {$I+} + inc(needs,sizeof(userrec)*filesize(uf1)); + close(uf1); + end; + + if needc('3') then begin + ss('boards.dat'); + assign(bf1,gp+'boards.dat'); + {$I-} reset(bf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(bf1,brd1); {$I+} + inc(needs,sizeof(boardrec)*filesize(bf1)); + close(bf1); + end; + + if needc('4') then begin + ss('email.dat'); + assign(mailfile1,gp+'email.dat'); + {$I-} reset(mailfile1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(mailfile1,mail1); {$I+} + inc(needs,sizeof(mailrec)*filesize(mailfile1)); + close(mailfile1); + end; + + if needc('5') then begin + ss('gfiles.dat'); + assign(gfilef1,gp+'gfiles.dat'); + {$I-} reset(gfilef1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(gfilef1,gfile1); {$I+} + inc(needs,sizeof(tfilerec)*filesize(gfilef1)); + close(gfilef1); + end; + + if needc('6') then begin + ss('protocol.dat'); + assign(xp1,gp+'protocol.dat'); + {$I-} reset(xp1); {$I+} + if (ioresult<>0) then cantopen; + inc(needs,sizeof(protrec)*filesize(xp1)); + close(xp1); + end; + + if needc('7') then begin + ss('shortmsg.dat'); + assign(smf1,gp+'shortmsg.dat'); + {$I-} reset(smf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(smf1,sm1); {$I+} + inc(needs,sizeof(smalrec)*filesize(smf1)); + close(smf1); + end; + + if needc('8') then begin + ss('uploads.dat'); + assign(ulf1,gp+'uploads.dat'); + {$I-} reset(ulf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(ulf1,ubrd1); {$I+} + inc(needs,sizeof(ulrec)*filesize(ulf1)); + close(ulf1); + end; + + if needc('9') then begin + ss('voting.dat'); + assign(vdf1,gp+'voting.dat'); + {$I-} reset(vdf1); {$I+} + inc(needs,sizeof(vdatar)*filesize(vdf1)); + if (ioresult=0) then close(vdf1); + end; + + if needc('A') then begin + ss('zlog.dat'); + assign(ztf1,gp+'zlog.dat'); + {$I-} reset(ztf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(ztf1,zt1); {$I+} + inc(needs,sizeof(zlogrec)*filesize(ztf1)); + close(ztf1); + end; + + if needc('B') then begin + ss('*.dir'); + ffile(gp+'*.dir'); + while (found) do begin + assign(ulff1,fexpand(gp+dirinfo.name)); + {$I-} reset(ulff1); {$I+} + inc(needs,sizeof(ulfrec)*filesize(ulff1)); + close(ulff1); + nfile; + end; + end; +end; + +function barconv(c:char):char; +var s:astr; +begin + if (pos(c,artable)<>0) then s:=copy('ABCDEFG',pos(c,artable),1) else s:='@'; + barconv:=s[1]; +end; + +function arconv(c:char):char; +begin + if (c in ['A'..'G']) then + if (length(artable)>=ord(c)-64) and (artable[ord(c)-64] in ['@'..'Z']) then + arconv:=artable[ord(c)-64] + else arconv:='@' + else arconv:='@'; +end; + +function substall(src,old,new:astr):astr; +var p:integer; +begin + p:=1; + while (p>0) do begin + p:=pos(old,src); + if (p>0) then begin + insert(new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substall:=src; +end; + +procedure bconvert(xx:integer); +var i,j,k:integer; + s:astr; + b:boolean; +begin +end; + +procedure fconvert(xx:integer); +const dcols:clrs=((15,7,7,15,15,15,112,7,143,7),(15,3,1,11,9,14,31,4,140,10)); +var i,j,k:integer; + b:boolean; + s,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15:astr; + c:char; + mf,mf1:text; + sepmsgs,nocopy,bla,b1,b2:boolean; + f:file; + mary:array[0..200] of messagerec; + curdir:astr; + newpath:array[1..3] of astr; + fff:file; + menuline:array[1..13] of string[255]; + uu:uflags1; + numread:word; + + procedure make_paths; + var s:string; + i,j:integer; + begin + for i:=1 to 3 do begin + while copy(newpath[i],length(newpath[i]),1)='\' do + newpath[i]:=copy(newpath[i],1,length(newpath[i])-1); + case i of 1:s:='AFILES'; 2:s:='TRAP'; 3:s:='TEMP'; end; + star(s+' path ("'+fexpand(newpath[i])+'")'); + {$I-} mkdir(fexpand(newpath[i])); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(newpath[i])+'"'); + halt(1); + end; + if (i=3) then + for j:=1 to 3 do begin + {$I-} mkdir(fexpand(newpath[i]+'\'+cstr(j))); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(newpath[i]+'\'+cstr(j))+'"'); + halt(1); + end; + end; + newpath[i]:=newpath[i]+'\'; + end; + end; + + function sacs(b:byte):string; + begin + if (b>0) then sacs:='s'+cstr(b) else sacs:=''; + end; + +begin + case xx of + 14:begin + ttl('Adding records to "MODEM.DAT"'); + chdir(copy(gp,1,length(gp)-1)); + ffile('modem.dat'); + if (not found) then star('MODEM.DAT not found.') + else begin + assign(modemrf17a7,'modem.old'); rewrite(modemrf17a7); + close(modemrf17a7); erase(modemrf17a7); + + assign(modemrf17a7,'modem.tcp'); rewrite(modemrf17a7); + close(modemrf17a7); erase(modemrf17a7); + + assign(modemrf,'modem.tcp'); rewrite(modemrf); + assign(modemrf17a7,'modem.dat'); + reset(modemrf17a7); read(modemrf17a7,modemr17a7); + + with modemr17a7 do begin + modemr.waitbaud:=waitbaud; + modemr.comport:=comport; + modemr.init:=init; + modemr.answer:=answer; + modemr.hangup:=hangup; + modemr.offhook:=offhook; + modemr.nocallinittime:=nocallinittime; + modemr.arq9600rate:=arq9600rate; + modemr.noforcerate:=noforcerate; + modemr.nocarrier:=nocarrier; + modemr.nodialtone:=nodialtone; + modemr.busy:=busy; + for i:=1 to 2 do + for j:=0 to 4 do modemr.resultcode[i][j]:=resultcode[i][j]; + modemr.ctschecking:=TRUE; + modemr.dsrchecking:=TRUE; + modemr.usexonxoff:=FALSE; + modemr.hardwired:=FALSE; + end; + + write(modemrf,modemr); + close(modemrf); + rename(modemrf17a7,'modem.old'); + rename(modemrf,'modem.dat'); + + star('Done.'); + writeln; + end; + chdir(sp); + end; + end; +end; + +procedure convert(xx:integer); +var s:astr; + i,j,k:integer; + c:char; +begin + case xx of + 0 :c:='S'; + 1..9 :c:=chr(xx+48); + 10..20:c:=chr(xx+55); + end; + if (needc(c)) then + if (back) then bconvert(xx) else fconvert(xx); +end; + +begin + infield_out_fgrd:=15; + infield_out_bkgd:=1; + infield_inp_fgrd:=0; + infield_inp_bkgd:=7; + + getdir(0,sp); + aw:=FALSE; + didit:=FALSE; + if paramcount>0 then if allcaps(paramstr(1))='C' then aw:=TRUE; + savx:=wherex; savy:=wherey; + setwindow(wind,1,1,80,25,7,0,0); + clrscr; + textbackground(1); textcolor(15); clreol; + write(' Telegard Conversion for '+ver1+' ¯¯¯¯¯¯¯¯¯ '+ver); + textbackground(0); + window(1,2,80,25); clrscr; + tc(14); + writeln; + writeln('This program is provided to add/modify/create files used by Telegard to'); + writeln('make it 100% functional under the '+ver+' environment. This file MUST'); + writeln('be ran in the directory in which STATUS.DAT is found, and STATUS.DAT MUST'); + writeln('be in '+ver1+' format!!! If STATUS.DAT is not in the current directory,'); + writeln('or if you have already ran this program (STATUS.DAT has already been'); + writeln('converted), this program will abort.'); + writeln; + tc(9); write('Hit any key to continue ( to abort NOW) : '); + repeat until keypressed; + c:=readkey; + if (c=#27) then ee('ABORTED CONVERSION'); + + repeat + clrscr; + fvers; + + if (not aw) then begin + writeln; + star('WARNING! This conversion program needs APPROXIMATELY'); + star(cstrl(needs)+' bytes free on your main BBS drive!!!!!!!!'); + writeln; + star('You currently have '+cstrl(freek(0)*1024)+' bytes left on the current drive.'); + writeln; + star('If you DO NOT have enough space left, your drive will probably'); + star('explode, and your house will burn to the ground. If you are'); + star('skeptical of this, feel free to call Garfield, SysOp of Electric'); + star('Eye ][ BBS (313/776-8928), who can tell you how bad HIS messed up'); + star('when he converted from 1.6d3 --> 1.6e1 with only 500k!'); + writeln; + if (not l_pynq('Proceed? ')) then ee('Aborted conversion'); + end; + + clrscr; + writeln; + if aw then begin + for i:=0 to 15 do begin + if (i>=1) and (i<=9) then c:=chr(i+48) else + if (i=0) then c:='S' else + if (i>=10) then c:=chr(i+55); + if (needc(c)) then begin + tc(9); write('['+cstr(i)+'] '); + if i<10 then write(' '); + tc(11); + case i of + 0:write('(S)tatus.dat'); + 1:write('names.lst'); + 2:write('user.lst'); + 3:write('boards.dat'); + 4:write('email.dat'); + 5:write('gfiles.dat'); + 6:write('protocol.dat'); + 7:write('shortmsg.dat'); + 8:write('uploads.dat'); + 9:write('voting.dat'); + 10:write('zlog.dat'); + 11:write(gp+'*.dir'); + 12:write(gp+'*.brd'); + 13:write(mp+'*.mnu'); + 14:write('modem.dat'); + 15:write('string.dat'); + end; + writeln; + end; + end; + writeln; + tc(14); write('Enter # to convert, (A)ll or (Q)uit :'); + tc(9); readln(a); a:=allcaps(a); + + j:=value(a); + end else + a:='A'; + + if (j=0) then + if (copy(a,1,1)='S') then j:=0 else j:=-1; + + if (copy(a,1,1)<>'Q') or ((j>=0) and (j<=13)) then begin + writeln; + if aw then begin + tc(14); write('[1]Convert to '+ver+' - [2]Convert back to '+ver1+' : '); + tc(9); readln(b); b:=allcaps(b); + h:=value(b); + end else + h:=1; + + if (h in [1,2]) then begin + clrscr; tc(15); + back:=FALSE; + if h=2 then back:=TRUE; + if back then begin + tc(31); + writeln('Convert '+ver+' ¯¯¯¯¯¯¯¯¯ '+ver1); + end else + writeln('Convert '+ver1+' ¯¯¯¯¯¯¯¯¯ '+ver); + writeln; + tc(4); write('WARNING: '); + tc(12); + if back then writeln('If files are not in version '+ver+' format,') else + writeln('If files are NOT in version '+ver1+' format,'); + writeln('the data will be COMPLETELY LOST *FOREVER*!!'); + writeln; + writeln; + tc(14); writeln('ARE YOU ABSOLUTELY SURE?'); + writeln('(Enter "YES" in ALL CAPS, without quotes, if you are...)'); + write(':'); + readln(b); + + if b='YES' then begin + clrscr; + + if copy(a,1,1)<>'A' then convert(j) + else begin + for i:=0 to 20 do convert(i); +{ ttl('Moving new files into their directories'); + smovefile('protocol.dat',systat.gfilepath); + smovefile('sysfunc.ans',systat.afilepath);} + end; + didit:=TRUE; + end; + end; + end; + if (not aw) then a:='Q'; + until copy(a,1,1)='Q'; + + writeln; + star('Press any key...'); c:=readkey; + clrscr; + removewindow(wind); + + if didit then begin + setwindow(wind,20,11,59,17,9,1,1); + clrscr; tc(15); + gotoxy(4,3); + write('Thank you for choosing Telegard!'); + CursorOff; delay(1500); CursorOn; + removewindow(wind); + end; + gotoxy(savx,savy); + chdir(sp); +end. diff --git a/conv18a.pas b/conv18a.pas new file mode 100644 index 0000000..c44c503 --- /dev/null +++ b/conv18a.pas @@ -0,0 +1,1660 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +{$M 50000,0,1024} + +uses crt,dos, + myio; + +const + needconv = 'S23568CD'; + standard_conversion = TRUE; + +{$I rcc17a.pas} +{$I rec18a.pas} + +var + a,b,lastss,mp,gp,sp:astr; + h,i,j,k,savx,savy:integer; + c:char; + aw:boolean; { author working } + back:boolean; { converting BACK TO PREVIOUS VERSION ! .. } + found:boolean; + dirinfo:searchrec; + ptsforisrequest,ptsfornotval:integer; + wind:windowrec; + didit:boolean; + needs:longint; + + artable:astr; + +{ systatf17a4:file of systatrec17a4;} +{ systat17a4:systatrec17a4;} + systatf1:file of systatrec1; + systat1:systatrec1; + systatf0:file of systatrec; + systat0:systatrec; + systatf:file of systatrec; + systat:systatrec; + + modemrf:file of modemrec; + modemr:modemrec; + fstringf:file of fstringrec; + fstring:fstringrec; + + sf1:file of smalrec1; + sr1:smalrec1; + sf:file of smalrec; + sr:smalrec; + + uf1:file of userrec1; + user1:userrec1; {**} + uf0:file of userrec; + user0:userrec; + uf:file of userrec; + user:userrec; {**} + + bf1:file of boardrec1; + brd1:boardrec1; +{ bf17a5:file of boardrec17a5;} +{ brd17a5:boardrec17a5;} + bf:file of boardrec; + brd:boardrec; + + mailfile1:file of mailrec1; + mail1:mailrec1; {**} + mailfile:file of mailrec; + mail:mailrec; {**} + + ulf1:file of ulrec1; + ubrd1:ulrec1; +{ ulf17a2:file of ulrec17a2;} +{ ubrd17a2:ulrec17a2;} + ulf0:file of ulrec; + ubrd0:ulrec; + ulf:file of ulrec; + ubrd:ulrec; + + ulff1:file of ulfrec1; + uld1:ulfrec1; + ulff:file of ulfrec; + uld:ulfrec; + +{ slf1:file of slr1; + seclev1:array[0..255] of slr1; + slf:file of seclevrec; + seclev:seclevrec;} + + gfilef1:file of gft1; {**} + gfile1:gft1; {**} + gfilef:file of tfilerec;{**} + gfile:tfilerec; {**} + + smf1:file of smr1; + sm1:smr1; + smf:file of smr; + sm:smr; + + ztf1:file of zlogt1; {**} + zt1:zlogt1; {**} + ztf:file of zlogrec; {**} + zt:zlogrec; {**} + + vdf1:file of vdatar1; {**} + vd1:vdatar1; {**} + vdf:file of vdatar; {**} + vd:vdatar; {**} + + macrf:file of macrorec; + macr:macrorec; + + xp1:file of protrec1; + xpr1:protrec1; + xp0:file of protrec; + xpr0:protrec; + xp:file of protrec; + xpr:protrec; + + mbasef1:file of messagerec1; + mbase1:messagerec1; + mbasef:file of messagerec; + mbase:messagerec; + + ff:file; + + {**} (* NOT defined globally in COMMON.PAS .... *) + +function value(I:astr):integer; +var n,n1:integer; +begin + val(i,n,n1); + if n1<>0 then begin + i:=copy(i,1,n1-1); + val(i,n,n1) + end; + value:=n; + if i='' then value:=0; +end; + +function cstrl(li:longint):astr; +var c:astr; +begin + str(li,c); + cstrl:=c; +end; + +function cstr(i:integer):astr; +var c:astr; +begin + str(i,c); + cstr:=c; +end; + + + +function tch(i:astr):astr; +begin + if length(i)>2 then i:=copy(i,length(i)-1,2) else + if length(i)=1 then i:='0'+i; + tch:=i; +end; + +function time:astr; +var reg:registers; + h,m,s:string[4]; +begin + reg.ax:=$2c00; intr($21,Dos.Registers(reg)); + str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s); + time:=tch(h)+':'+tch(m)+':'+tch(s); +end; + +function date:astr; +var reg:registers; + m,d,y:string[4]; +begin + reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y); str(reg.dx mod 256,d); + str(reg.dx shr 8,m); + date:=tch(m)+'/'+tch(d)+'/'+tch(y); +end; + +function leapyear(yr:integer):boolean; +begin + leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0)); +end; + +function days(mo,yr:integer):integer; +var d:integer; +begin + d:=value(copy('312831303130313130313031',1+(mo-1)*2,2)); + if (mo=2) and leapyear(yr) then d:=d+1; + days:=d; +end; + +function daycount(mo,yr:integer):integer; +var m,t:integer; +begin + t:=0; + for m:=1 to (mo-1) do t:=t+days(m,yr); + daycount:=t; +end; + +function daynum(dt:astr):integer; +var d,m,y,t,c:integer; +begin + t:=0; + m:=value(copy(dt,1,2)); + d:=value(copy(dt,4,2)); + y:=value(copy(dt,7,2))+1900; + for c:=1985 to y-1 do + if leapyear(c) then t:=t+366 else t:=t+365; + t:=t+daycount(m,y)+(d-1); + daynum:=t; + if y<1985 then daynum:=0; +end; + + +function freek(d:integer):longint; (* See disk space *) +{var r:registers;} +begin + freek:=diskfree(d) div 1024; +{ r.ax:=$3600; + r.dx:=d; + msdos(dos.registers(r)); + freek:=trunc(1.0*r.bx*r.ax*r.cx/1024.0);} +end; + +procedure tc(i:integer); +begin + textcolor(i); +end; + +procedure star(s:astr); +begin + tc(9); write('þ '); + tc(11); writeln(s); +end; + +function exdrv(s:astr):byte; +begin + s:=fexpand(s); + exdrv:=ord(s[1])-64; +end; + +procedure movefile(srcname,destpath:string); +var buffer:array[1..16384] of byte; + dfs,nrec:integer; + src,dest:file; + dd,dn,de:string; + + procedure dodate; + var r:registers; + od,ot,ha:integer; + begin + srcname:=srcname+#0; + destpath:=destpath+#0; + with r do begin + ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5700; msdos(dos.registers(r)); + od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(dos.registers(r)); + ax:=$3d02; ds:=seg(destpath[1]); dx:=ofs(destpath[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(dos.registers(r)); + ax:=$3e00; bx:=ha; msdos(dos.registers(r)); + end; + end; + +begin + fsplit(srcname,dd,dn,de); + destpath:=destpath+dn+de; + assign(src,srcname); + {$I-} reset(src,1); {$I+} + if (ioresult<>0) then begin + writeln; + star('"'+srcname+'": File not found.'^G^G); +{ halt(1);} + end else begin + dfs:=freek(exdrv(destpath)); + + {rcg11172000 don't have LONGfilesize()...} + {if (trunc(longfilesize(src)/1024.0)+1>=dfs) then begin} + if (trunc(filesize(src)/1024.0)+1>=dfs) then begin + writeln; + star('"'+srcname+'": Disk full.'); + halt(1); + end else begin + assign(dest,destpath); rewrite(dest,1); + repeat + blockread(src,buffer,16384,nrec); + blockwrite(dest,buffer,nrec); + until (nrec<16384); + close(dest); + close(src); + dodate; + erase(src); + end; + end; +end; + +procedure smovefile(srcname,destpath:string); +begin + star('Moving "'+srcname+'" to "'+destpath+'"'); + movefile(srcname,destpath); +end; + +procedure ffile(fn:astr); +begin + findfirst(fn,anyfile,dirinfo); + found:=(doserror=0); +end; + +procedure nfile; +var r:registers; +begin + findnext(dirinfo); + found:=(doserror=0); +end; + +function allcaps(s:astr):astr; (* returns a COMPLETELY capitalized string *) +var i:integer; +begin + for i:=1 to length(s) do + s[i]:=upcase(s[i]); + allcaps:=s; +end; + +procedure cursoron; +var reg:registers; +begin + with reg do begin + ch:=07; cl:=08; ah:=1; + intr($10,reg); + end; +end; + +procedure cursoroff; +var reg:registers; +begin + with reg do begin + ch:=09; cl:=00; ah:=1; + intr($10,reg); + end; +end; + +procedure prt(s:string); +begin + textcolor(9); write(s); +end; + +procedure ttl(s:string); +begin + writeln; + textcolor(9); write('ÄÄ['); + textbackground(1); textcolor(15); + write(' '+s+' '); + textbackground(0); textcolor(9); + write(']'); + repeat write('Ä') until wherex=80; + writeln; +end; + +procedure ee(s:astr); +begin + clrscr; + writeln; + tc(4); writeln('ERROR:'); + writeln; + tc(15); write(' '+s); + writeln; + writeln; + tc(9); write('Hit any key to exit : '); + repeat until keypressed; + c:=readkey; + removewindow(wind); gotoxy(savx,savy); + halt(1); +end; + +procedure ss(s:astr); +begin + lastss:=allcaps(s); + star('Searching for "'+lastss+'"'); +end; + +procedure cantopen; +begin + ee('Unable to open "'+lastss+'"'); +end; + +function needc(c:char):boolean; +begin + if pos(c,needconv)<>0 then needc:=TRUE else needc:=FALSE; +end; + +procedure fvers; +var i:integer; +begin + needs:=0; + + writeln; + ss('status.dat'); + assign(systatf1,'status.dat'); + {$I-} reset(systatf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(systatf1,systat1); {$I+} + if (ioresult<>0) then begin + close(systatf1); + assign(systatf,'status.dat'); + reset(systatf); + {$I-} read(systatf,systat); {$I+} + gp:=systat.gfilepath; + mp:=systat.menupath; + close(systatf); + end else begin + gp:=systat1.gfilepath; + mp:=systat1.menupath; + close(systatf1); + end; + inc(needs,sizeof(systatrec)); + + if needc('1') then begin + ss('names.lst'); + assign(sf1,gp+'names.lst'); + {$I-} reset(sf1); {$I+} + if (ioresult<>0) then begin + assign(systatf,'status.dat'); + reset(systatf); + {$I-} read(systatf,systat); {$I+} + gp:=systat.gfilepath; + mp:=systat.menupath; + close(systatf); + assign(sf1,gp+'names.lst'); + {$I-} reset(sf1); {$I+} + if (ioresult<>0) then cantopen; + end; + {$I-} read(sf1,sr1); {$I+} + inc(needs,sizeof(smalrec)*filesize(sf1)); + close(sf1); + end; + + if needc('2') then begin + ss('user.lst'); + assign(uf1,gp+'user.lst'); + {$I-} reset(uf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(uf1,user1); {$I+} + inc(needs,sizeof(userrec)*filesize(uf1)); + close(uf1); + end; + + if needc('3') then begin + ss('boards.dat'); + assign(bf1,gp+'boards.dat'); + {$I-} reset(bf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(bf1,brd1); {$I+} + inc(needs,sizeof(boardrec)*filesize(bf1)); + close(bf1); + end; + + if needc('4') then begin + ss('email.dat'); + assign(mailfile1,gp+'email.dat'); + {$I-} reset(mailfile1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(mailfile1,mail1); {$I+} + inc(needs,sizeof(mailrec)*filesize(mailfile1)); + close(mailfile1); + end; + + if needc('5') then begin + ss('gfiles.dat'); + assign(gfilef1,gp+'gfiles.dat'); + {$I-} reset(gfilef1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(gfilef1,gfile1); {$I+} + inc(needs,sizeof(tfilerec)*filesize(gfilef1)); + close(gfilef1); + end; + + if needc('6') then begin + ss('protocol.dat'); + assign(xp1,gp+'protocol.dat'); + {$I-} reset(xp1); {$I+} + if (ioresult<>0) then cantopen; + inc(needs,sizeof(protrec)*filesize(xp1)); + close(xp1); + end; + + if needc('7') then begin + ss('shortmsg.dat'); + assign(smf1,gp+'shortmsg.dat'); + {$I-} reset(smf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(smf1,sm1); {$I+} + inc(needs,sizeof(smalrec)*filesize(smf1)); + close(smf1); + end; + + if needc('8') then begin + ss('uploads.dat'); + assign(ulf1,gp+'uploads.dat'); + {$I-} reset(ulf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(ulf1,ubrd1); {$I+} + inc(needs,sizeof(ulrec)*filesize(ulf1)); + close(ulf1); + end; + + if needc('9') then begin + ss('voting.dat'); + assign(vdf1,gp+'voting.dat'); + {$I-} reset(vdf1); {$I+} + inc(needs,sizeof(vdatar)*filesize(vdf1)); + if (ioresult=0) then close(vdf1); + end; + + if needc('A') then begin + ss('zlog.dat'); + assign(ztf1,gp+'zlog.dat'); + {$I-} reset(ztf1); {$I+} + if (ioresult<>0) then cantopen; + {$I-} read(ztf1,zt1); {$I+} + inc(needs,sizeof(zlogrec)*filesize(ztf1)); + close(ztf1); + end; + + if needc('B') then begin + ss('*.dir'); + ffile(gp+'*.dir'); + while (found) do begin + assign(ulff1,fexpand(gp+dirinfo.name)); + {$I-} reset(ulff1); {$I+} + inc(needs,sizeof(ulfrec)*filesize(ulff1)); + close(ulff1); + nfile; + end; + end; +end; + +function barconv(c:char):char; +var s:astr; +begin + if (pos(c,artable)<>0) then s:=copy('ABCDEFG',pos(c,artable),1) else s:='@'; + barconv:=s[1]; +end; + +function arconv(c:char):char; +begin + if (c in ['A'..'G']) then + if (length(artable)>=ord(c)-64) and (artable[ord(c)-64] in ['@'..'Z']) then + arconv:=artable[ord(c)-64] + else arconv:='@' + else arconv:='@'; +end; + + +{rcg11172000 had to change this to get it compiling under Free Pascal...} +{function substall(src,old,new:astr):astr;} +function substall(src,old,_new:astr):astr; +var p:integer; +begin + p:=1; + while (p>0) do begin + p:=pos(old,src); + if (p>0) then begin + insert(_new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substall:=src; +end; + +procedure bconvert(xx:integer); +var i,j,k:integer; + s:astr; + b:boolean; +begin + case xx of +(* + 6:begin + ttl('BACKWARD Converting "PROTOCOL.DAT'); + chdir(copy(gp,1,length(gp)-1)); + ffile('protocol.dat'); + if (not found) then star('PROTOCOL.DAT not found.') + else begin + + assign(xp,'protocol.old'); rewrite(xp); close(xp); erase(xp); + assign(xp,'protocol.tcp'); rewrite(xp); close(xp); erase(xp); + assign(xp,'protocol.dat'); reset(xp); + assign(xp1,'protocol.tcp'); rewrite(xp1); + + for i:=0 to filesize(xp)-1 do begin + seek(xp,i); read(xp,xpr); + star(' (record #'+cstr(i)+' of '+cstr(filesize(xp)-1)+')'); gotoxy(1,wherey-1); + + with xpr1 do begin + active:=(xbactive in xpr.xbstat); + isbatch:=(xbisbatch in xpr.xbstat); + isresume:=(xbisresume in xpr.xbstat); + xferokcode:=(xbxferokcode in xpr.xbstat); + ckeys:=xpr.ckeys; + descr:=xpr.descr; + minbaud:=xpr.minbaud; + maxbaud:=19200; maxbaud:=maxbaud*2; + sl:=xpr.sl; + dsl:=xpr.dsl; + ar:=xpr.ar; + templog:=xpr.templog; + uloadlog:=xpr.uloadlog; + dloadlog:=xpr.dloadlog; + ulcmd:=xpr.ulcmd; + dlcmd:=xpr.dlcmd; + for j:=1 to 6 do begin + ulcode[j]:=xpr.ulcode[j]; + dlcode[j]:=xpr.dlcode[j]; + end; + envcmd:=xpr.envcmd; + dlflist:=xpr.dlflist; + maxchrs:=xpr.maxchrs; + logpf:=xpr.logpf; + logps:=xpr.logps; + end; + + seek(xp1,i); write(xp1,xpr1); + end; + close(xp); + close(xp1); + rename(xp,'protocol.old'); + rename(xp1,'protocol.dat'); + writeln; + end; + chdir(sp); + end; +*) + 12:begin + ttl('-®<®--BACKWARD--®<®- Converting "*.BRD" message base info files'); + chdir(copy(gp,1,length(gp)-1)); + ffile('*.brd'); + if not found then star('No *.BRD files present.') + else begin + repeat + s:=dirinfo.name; + + assign(mbasef,copy(s,1,length(s)-3)+'old'); rewrite(mbasef); + close(mbasef); erase(mbasef); + + assign(mbasef,copy(s,1,length(s)-3)+'tcp'); rewrite(mbasef); + close(mbasef); erase(mbasef); + + assign(mbasef,s); reset(mbasef); + + assign(mbasef1,copy(s,1,length(s)-3)+'tcp'); rewrite(mbasef1); + + star('Converting "'+s+'" ('+cstr(filesize(mbasef)-1)+' messages)'); + + for i:=0 to filesize(mbasef)-1 do begin + seek(mbasef,i); read(mbasef,mbase); + with mbase do begin + mbase1.title:=title; + if (validated in messagestat) then mbase1.messagestat:=validated1; + if (unvalidated in messagestat) then mbase1.messagestat:=unvalidated1; + if (deleted in messagestat) then mbase1.messagestat:=deleted1; + mbase1.message.ltr:=message.ltr; + mbase1.message.number:=message.number; + mbase1.message.ext:=message.ext; + mbase1.owner:=owner; + mbase1.date:=mbase1.date; + mbase1.mage:=255; + end; + write(mbasef1,mbase1); + end; + + close(mbasef1); + close(mbasef); + rename(mbasef1,copy(s,1,length(s)-3)+'obr'); + + nfile; + until (not found); + ffile('*.obr'); + while (found) do begin + s:=dirinfo.name; + assign(mbasef1,copy(s,1,length(s)-3)+'brd'); + rename(mbasef1,copy(s,1,length(s)-3)+'old'); + assign(mbasef,s); rename(mbasef,copy(s,1,length(s)-3)+'brd'); + nfile; + end; + end; + chdir(sp); + end; + end; +end; + +procedure fconvert(xx:integer); +const dcols:clrs=((15,7,7,15,15,15,112,7,143,7),(15,3,1,11,9,14,31,4,140,10)); +var i,j,k:integer; + b:boolean; + s,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15:astr; + c:char; + mf,mf1:text; + sepmsgs,nocopy,bla,b1,b2:boolean; + f:file; + mary:array[0..200] of messagerec; + curdir:astr; + newpath:array[1..3] of astr; + fff:file; + menuline:array[1..13] of string[255]; + uu:uflags1; + numread:word; + + procedure make_paths; + var s:string; + i,j:integer; + begin + for i:=1 to 3 do begin + while copy(newpath[i],length(newpath[i]),1)='\' do + newpath[i]:=copy(newpath[i],1,length(newpath[i])-1); + case i of 1:s:='AFILES'; 2:s:='TRAP'; 3:s:='TEMP'; end; + star(s+' path ("'+fexpand(newpath[i])+'")'); + {$I-} mkdir(fexpand(newpath[i])); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(newpath[i])+'"'); + halt(1); + end; + if (i=3) then + for j:=1 to 3 do begin + {$I-} mkdir(fexpand(newpath[i]+'\'+cstr(j))); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(newpath[i]+'\'+cstr(j))+'"'); + halt(1); + end; + end; + newpath[i]:=newpath[i]+'\'; + end; + end; + + function sacs(b:byte):string; + begin + if (b>0) then sacs:='s'+cstr(b) else sacs:=''; + end; + +begin + case xx of + 0:begin + ttl('Converting "STATUS.DAT"'); + ffile('status.dat'); + if (not found) then star('STATUS.DAT not found.') + else begin + + assign(systatf1,'status.old'); rewrite(systatf1); close(systatf1); erase(systatf1); + assign(systatf1,'status.tcp'); rewrite(systatf1); close(systatf1); erase(systatf1); + + assign(systatf,'status.tcp'); rewrite(systatf); + assign(systatf1,'status.dat'); + + reset(systatf1); read(systatf1,systat1); + + if (standard_conversion) then { default settings for STANDARDs } + with systat1 do begin + arq9600rate:=9600; + allstartmenu:='MAIN'; + wfcblanktime:=0; + validateallfiles:=FALSE; + maxintemp:=500; + slogtype:=0; + stripclog:=FALSE; + noforcerate:=FALSE; + rebootforevent:=TRUE; + minresume:=100; + windowon:=TRUE; + curwindow:=1; + end; + + with systat1 do begin + systat.gfilepath:=gfilepath; + systat.afilepath:=afilepath; + systat.menupath:=menupath; + systat.trappath:=trappath; + systat.pmsgpath:=pmsgpath; + systat.tfilepath:=tfilepath; + systat.temppath:=temppath; + + systat.bbsname:=bbsname; + systat.bbsphone:=bbsphone; + systat.sysopname:=sysopfirst+' '+sysoplast; +{**} systat.maxusers:=500; + systat.lowtime:=lowtime; + systat.hitime:=hitime; + systat.dllowtime:=dllowtime; + systat.dlhitime:=dlhitime; + systat.shuttlelog:=matrix; + systat.lock300:=lock300; + systat.sysoppw:=sysoppw; + systat.newuserpw:=boardpw; + systat.shuttlepw:=bbspw; + systat.b300lowtime:=b300lowtime; + systat.b300hitime:=b300hitime; + systat.b300dllowtime:=b300dllowtime; + systat.b300dlhitime:=b300dlhitime; + systat.closedsystem:=closedsystem; + systat.snowchecking:=snowchecking; + systat.eventwarningtime:=eventwarningtime; + systat.tfiledate:=tfiledate; + systat.hmsg.ltr:=hmsg.ltr; + systat.hmsg.number:=hmsg.number; + systat.hmsg.ext:=hmsg.ext; + for j:=1 to 20 do systat.res[j]:=0; + + systat.sop:=sacs(sop); + systat.csop:=sacs(csop); + systat.msop:=sacs(msop); + systat.fsop:=sacs(fsop); + systat.spw:=sacs(spw); + systat.seepw:=sacs(seepw); + systat.normpubpost:=sacs(normpubpost); + systat.normprivpost:=sacs(normprivpost); + systat.anonpubread:=sacs(anonpubread); + systat.anonprivread:=sacs(anonprivread); + systat.anonpubpost:=sacs(anonpubpost); + systat.anonprivpost:=sacs(anonprivpost); + systat.seeunval:=sacs(seeunval); + systat.dlunval:=sacs(dlunval); + systat.nodlratio:=sacs(nodlratio); + systat.nopostratio:=sacs(nopostratio); + systat.nofilepts:=sacs(nofilepts); + systat.ulvalreq:=sacs(ulvalreq); + for j:=1 to 100 do systat.res2[j]:=0; + + systat.maxprivpost:=maxprivpost; + systat.maxfback:=maxfback; + systat.maxpubpost:=maxpubpost; + systat.maxchat:=maxchat; + systat.maxwaiting:=maxwaiting; + systat.csmaxwaiting:=csmaxwaiting; + systat.maxlines:=maxlines; + systat.csmaxlines:=csmaxlines; + systat.maxlogontries:=tries; + systat.bsdelay:=bsdelay; + systat.sysopcolor:=sysopcolor; + systat.usercolor:=usercolor; + systat.minspaceforpost:=minspaceforpost; + systat.minspaceforupload:=minspaceforupload; + systat.backsysoplogs:=backsysoplogs; + systat.wfcblanktime:=wfcblanktime; + for j:=1 to 20 do systat.res3[j]:=0; + + systat.specialfx:=special; + systat.clearmsg:=clearmsg; + systat.allowalias:=alias; + systat.phonepw:=fone; + systat.localsec:=localsec; + systat.localscreensec:=localscreensec; + systat.globaltrap:=globaltrap; + systat.autochatopen:=autochatopen; + systat.autominlogon:=autominlogon; + systat.bullinlogon:=bullinlogon; + systat.lcallinlogon:=lcallinlogon; + systat.yourinfoinlogon:=yourinfoinlogon; + systat.multitask:=multitask; + systat.offhooklocallogon:=offhooklocallogon; + systat.forcevoting:=forcevoting; + systat.compressbases:=compressbases; + systat.searchdup:=searchdup; + systat.slogtype:=slogtype; + systat.stripclog:=stripclog; + systat.newapp:=app; + systat.guestuser:=guestuser; + systat.timeoutbell:=timeoutbell; + systat.timeout:=timeout; + for j:=1 to 20 do systat.res4[j]:=0; + + for j:=1 to maxarcs1 do begin + systat.filearcinfo[j].active:=filearcinfo[j].active; + systat.filearcinfo[j].ext:=filearcinfo[j].ext; + systat.filearcinfo[j].listline:=filearcinfo[j].listline; + systat.filearcinfo[j].arcline:=filearcinfo[j].arcline; + systat.filearcinfo[j].unarcline:=filearcinfo[j].unarcline; + systat.filearcinfo[j].testline:=filearcinfo[j].testline; + systat.filearcinfo[j].cmtline:=filearcinfo[j].cmtline; + systat.filearcinfo[j].succlevel:=filearcinfo[j].succlevel; + end; + systat.filearcinfo[7].ext:=''; + systat.filearcinfo[8].ext:=''; + for j:=1 to 3 do systat.filearccomment[j]:=filearccomment[j]; + systat.uldlratio:=uldlratio; + systat.fileptratio:=fileptratio; + systat.fileptcomp:=fileptcomp; + systat.fileptcompbasesize:=fileptcompbasesize; + systat.ulrefund:=ulrefund; + systat.tosysopdir:=tosysopdir; + systat.validateallfiles:=validateallfiles; + systat.remdevice:=remdevice; + systat.maxintemp:=maxintemp; + systat.minresume:=minresume; +{**} systat.maxdbatch:=30; +{**} systat.maxubatch:=30; + for j:=1 to 30 do systat.res5[j]:=0; + + systat.newsl:=newsl; + systat.newdsl:=newdsl; + systat.newar:=[]; + for c:='A' to 'Z' do + if (c in newar) then systat.newar:=systat.newar+[c]; + systat.newac:=[]; + if (rlogon1 in newac) then systat.newac:=systat.newac+[rlogon]; + if (rchat1 in newac) then systat.newac:=systat.newac+[rchat]; + if (rvalidate1 in newac) then systat.newac:=systat.newac+[rvalidate]; + if (rbackspace1 in newac) then systat.newac:=systat.newac+[rbackspace]; + if (ramsg1 in newac) then systat.newac:=systat.newac+[ramsg]; + if (rpostan1 in newac) then systat.newac:=systat.newac+[rpostan]; + if (rpost1 in newac) then systat.newac:=systat.newac+[rpost]; + if (remail1 in newac) then systat.newac:=systat.newac+[remail]; + if (rvoting1 in newac) then systat.newac:=systat.newac+[rvoting]; + if (rmsg1 in newac) then systat.newac:=systat.newac+[rmsg]; + if (fnodlratio1 in newac) then systat.newac:=systat.newac+[fnodlratio]; + if (fnopostratio1 in newac) then systat.newac:=systat.newac+[fnopostratio]; + if (fnofilepts1 in newac) then systat.newac:=systat.newac+[fnofilepts]; + if (fnodeletion1 in newac) then systat.newac:=systat.newac+[fnodeletion]; + systat.newfp:=newfp; + systat.autosl:=autosl; + systat.autodsl:=autodsl; + systat.autoar:=[]; + for c:='A' to 'Z' do + if (c in autoar) then systat.autoar:=systat.autoar+[c]; + systat.autoac:=[]; + if (rlogon1 in autoac) then systat.autoac:=systat.autoac+[rlogon]; + if (rchat1 in autoac) then systat.autoac:=systat.autoac+[rchat]; + if (rvalidate1 in autoac) then systat.autoac:=systat.autoac+[rvalidate]; + if (rbackspace1 in autoac) then systat.autoac:=systat.autoac+[rbackspace]; + if (ramsg1 in autoac) then systat.autoac:=systat.autoac+[ramsg]; + if (rpostan1 in autoac) then systat.autoac:=systat.autoac+[rpostan]; + if (rpost1 in autoac) then systat.autoac:=systat.autoac+[rpost]; + if (remail1 in autoac) then systat.autoac:=systat.autoac+[remail]; + if (rvoting1 in autoac) then systat.autoac:=systat.autoac+[rvoting]; + if (rmsg1 in autoac) then systat.autoac:=systat.autoac+[rmsg]; + if (fnodlratio1 in autoac) then systat.autoac:=systat.autoac+[fnodlratio]; + if (fnopostratio1 in autoac) then systat.autoac:=systat.autoac+[fnopostratio]; + if (fnofilepts1 in autoac) then systat.autoac:=systat.autoac+[fnofilepts]; + if (fnodeletion1 in autoac) then systat.autoac:=systat.autoac+[fnodeletion]; + + systat.allstartmenu:=allstartmenu; + for j:=1 to 50 do systat.res6[j]:=0; + + for j:=0 to 255 do systat.timeallow[j]:=timeallow[j]; + for j:=0 to 255 do systat.callallow[j]:=callallow[j]; + for j:=0 to 255 do systat.dlratio[j]:=dlratio[j]; + for j:=0 to 255 do systat.dlkratio[j]:=dlkratio[j]; + for j:=0 to 255 do systat.postratio[j]:=postratio[j]; + + systat.lastdate:=lastdate; + systat.curwindow:=1; + systat.istopwindow:=istopwindow; + systat.callernum:=callernum; + systat.numusers:=users; + + systat.todayzlog.date:=lastdate; + for j:=0 to 4 do systat.todayzlog.userbaud[j]:=userbaud[j]; + systat.todayzlog.active:=activetoday; + systat.todayzlog.calls:=callstoday; + systat.todayzlog.newusers:=newusertoday; + systat.todayzlog.pubpost:=msgposttoday; + systat.todayzlog.privpost:=emailtoday; + systat.todayzlog.fback:=fbacktoday; + systat.todayzlog.criterr:=criterr; + systat.todayzlog.uploads:=uptoday; + systat.todayzlog.downloads:=dntoday; + systat.todayzlog.uk:=newuk; + systat.todayzlog.dk:=newdk; + +{**} systat.postcredits:=0; +{**} systat.rebootforevent:=TRUE; +{**} systat.watchdogdoor:=TRUE; + for j:=1 to 200 do res[j]:=0; + + end; + + seek(systatf,0); write(systatf,systat); + + star('Done.'); + writeln; + ttl('Generating "MODEM.DAT" *from* "STATUS.DAT"'); + + assign(modemrf,systat.gfilepath+'modem.dat'); + rewrite(modemrf); + with systat1 do begin + modemr.waitbaud:=maxbaud; + modemr.comport:=comport; + modemr.init:=init; + modemr.answer:=answer; + modemr.hangup:=hangup; + modemr.offhook:=offhook; + modemr.nocallinittime:=nocallinittime; + modemr.arq9600rate:=arq9600rate; + modemr.noforcerate:=noforcerate; + modemr.nocarrier:=nocarrier; + modemr.nodialtone:=nodialtone; + modemr.busy:=busy; + for i:=1 to 2 do + for j:=0 to 4 do modemr.resultcode[i][j]:=resultcode[i][j]; + modemr.ctschecking:=TRUE; + modemr.dsrchecking:=TRUE; + modemr.usexonxoff:=FALSE; + modemr.hardwired:=FALSE; + end; + write(modemrf,modemr); + close(modemrf); + + star('Done.'); + writeln; + ttl('Generating "STRING.DAT" *from* "STATUS.DAT"'); + + assign(fstringf,systat.gfilepath+'string.dat'); + rewrite(fstringf); + with systat1 do begin + fstring.ansiq:=ansiq; + for j:=1 to 2 do fstring.note[j]:=note[j]; + fstring.lprompt:=lprompt; + fstring.echoc:=echoc; + fstring.sysopin:=sysopin; + fstring.sysopout:=sysopout; + fstring.engage:=engage; + fstring.endchat:=endchat; + fstring.wait:=wait; + fstring.pause:=pause; + fstring.entermsg1:=msg1; + fstring.entermsg2:=msg2; + fstring.newscan1:=new1; + fstring.newscan2:=new2; + fstring.scanmessage:=read; + fstring.automsgt:=auto1; + fstring.autom:=autom; + + fstring.shelldos1:=#3#5+'>> '+systat.sysopname+' has Shelled to dos, please wait ...'; + fstring.shelldos2:=#3#5+'>> Thank you for waiting'; + fstring.chatcall1:=#3#0+'Paging '+systat.sysopname+' for chat, please wait.....'; + fstring.chatcall2:=#3#7+' >>'+#3#5+'<'+#3#8+'*'+#3#5+'>'+#3#7+'<<'; + fstring.guestline:='Enter "GUEST" as your user name to be a guest user on the system.'; + fstring.namenotfound:=#3#5+'That name is'+#3#8+' NOT'+#3#5+' found in the user list.'; + fstring.bulletinline:=#3#4+'Enter Bulletin Selection (XX,?,Q=Quit) : '; + fstring.thanxvote:=#3#3+'Thanks for taking the time to vote!'; + + fstring.listline:='List files - P to Pause'; + fstring.newline:='Search for new files -'; + fstring.searchline:='Search all directories for a file mask -'; + fstring.findline1:='Search descriptions and filenames for keyword -'; + fstring.findline2:='Enter the string to search for:'; + fstring.downloadline:='Download - You have @P file points.'; + fstring.uploadline:='Upload - @Kk free on this drive'; + fstring.viewline:='View archive interior files -@MP to Pause, N for Next file'; + fstring.nofilepts:=#3#8+'Access denied: '+#3#5+'Insufficient file points to download.'; + fstring.unbalance:=#3#8+'Access denied: '+#3#5+'Your upload/download ratio is out of balance:'; + + fstring.pninfo:='P to Pause, N for next directory'; + fstring.gfnline1:='[Enter]=All files'; + fstring.gfnline2:=#3#4+'File mask: '; + fstring.batchadd:='File added to batch queue.'; + end; + write(fstringf,fstring); + close(fstringf); + + star('Done.'); + writeln; + + close(systatf); + close(systatf1); + rename(systatf1,'status.old'); + rename(systatf,'status.dat'); + + writeln; + end; + end; + 2:begin + ttl('PATCHING "USER.LST" - No conversion necessary'); + chdir(copy(gp,1,length(gp)-1)); + ffile('user.lst'); + if not found then star('USER.LST not found.') + else begin + assign(uf0,'user.old'); rewrite(uf0); close(uf0); erase(uf0); + assign(uf0,'user.lst'); rename(uf0,'user.old'); reset(uf0); + assign(uf1,'user.old'); reset(uf1); + assign(uf,'user.lst'); rewrite(uf); + + for i:=0 to filesize(uf0)-1 do begin + seek(uf0,i); read(uf0,user0); + seek(uf1,i); read(uf1,user1); + star(' (record #'+cstr(i)+' of '+cstr(filesize(uf0)-1)+')'); gotoxy(1,wherey-1); + user:=user0; + + user.ttimeon:=round(user1.ttimeon); + user.uk:=round(user1.uk); + user.dk:=round(user1.dk); + user.credit:=round(user1.credit); + + user.chatauto:=FALSE; + user.chatseperate:=FALSE; + + seek(uf,i); write(uf,user); + end; + close(uf0); + close(uf); + writeln; + end; + chdir(sp); + end; + 3:begin + ttl('Converting "BOARDS.DAT'); + chdir(copy(gp,1,length(gp)-1)); + ffile('boards.dat'); + if (not found) then star('BOARDS.DAT not found.') + else begin + assign(bf1,'boards.old'); rewrite(bf1); close(bf1); erase(bf1); + assign(bf1,'boards.tcp'); rewrite(bf1); close(bf1); erase(bf1); + assign(bf1,'boards.dat'); reset(bf1); + assign(bf,'boards.tcp'); rewrite(bf); + + for i:=0 to filesize(bf1)-1 do begin + seek(bf1,i); read(bf1,brd1); + star(' (record #'+cstr(i)+' of '+cstr(filesize(bf1)-1)+')'); gotoxy(1,wherey-1); + + with brd1 do begin + brd.name:=name; + brd.filename:=filename; + brd.msgpath:=msgpath; + brd.acs:=''; + if (sl<>0) then brd.acs:=brd.acs+'s'+cstr(sl); + if (ar in ['A'..'Z']) then brd.acs:=brd.acs+'f'+ar; + brd.postacs:=''; + if (postsl<>0) then brd.postacs:=brd.postacs+'s'+cstr(postsl); + brd.mciacs:=''; + brd.maxmsgs:=maxmsgs; + if (anonymous=yes1) then brd.anonymous:=yes else + if (anonymous=no1) then brd.anonymous:=no else + if (anonymous=forced1) then brd.anonymous:=forced else + if (anonymous=dearabby1) then brd.anonymous:=dearabby; + brd.password:=password; + brd.mbstat:=[]; + brd.permindx:=i; + brd.mbdepth:=0; + for j:=1 to 4 do brd.res[j]:=0; + end; + + seek(bf,i); write(bf,brd); + end; + close(bf1); + close(bf); + rename(bf1,'boards.old'); + rename(bf,'boards.dat'); + writeln; + end; + chdir(sp); + end; + 5:begin + ttl('Converting "GFILES.DAT'); + chdir(copy(gp,1,length(gp)-1)); + ffile('gfiles.dat'); + if (not found) then star('GFILES.DAT not found.') + else begin + + assign(gfilef1,'gfiles.old'); rewrite(gfilef1); close(gfilef1); erase(gfilef1); + assign(gfilef1,'gfiles.tcp'); rewrite(gfilef1); close(gfilef1); erase(gfilef1); + assign(gfilef1,'gfiles.dat'); reset(gfilef1); + assign(gfilef,'gfiles.tcp'); rewrite(gfilef); + + for i:=0 to filesize(gfilef1)-1 do begin + seek(gfilef1,i); read(gfilef1,gfile1); + star(' (record #'+cstr(i)+' of '+cstr(filesize(gfilef1)-1)+')'); gotoxy(1,wherey-1); + + if (i=0) then gfile.gdaten:=gfile1.num + else + with gfile do begin + title:=gfile1.title; + filen:=gfile1.filen; + gdate:=gfile1.gdate; + gdaten:=gfile1.gdaten; + acs:=''; + if (gfile1.num>0) then acs:=acs+'s'+cstr(gfile1.num); + if (gfile1.ar in ['A'..'Z']) then acs:=acs+'f'+gfile1.ar; + if (filen=#1#0#0#0#0#0) then ulacs:='%' else ulacs:=''; + tbstat:=[]; + permindx:=i; + tbdepth:=0; + for j:=1 to 4 do res[j]:=0; + end; + + seek(gfilef,i); write(gfilef,gfile); + end; + close(gfilef1); + close(gfilef); + rename(gfilef1,'gfiles.old'); + rename(gfilef,'gfiles.dat'); + writeln; + end; + chdir(sp); + end; + 6:begin + ttl('Converting "PROTOCOL.DAT'); + chdir(copy(gp,1,length(gp)-1)); + ffile('protocol.dat'); + if (not found) then star('PROTOCOL.DAT not found.') + else begin + assign(xp1,'protocol.old'); rewrite(xp1); close(xp1); erase(xp1); + assign(xp1,'protocol.tcp'); rewrite(xp1); close(xp1); erase(xp1); + assign(xp1,'protocol.dat'); reset(xp1); + assign(xp,'protocol.tcp'); rewrite(xp); + + for i:=0 to filesize(xp1)-1 do begin + seek(xp1,i); read(xp1,xpr1); + star(' (record #'+cstr(i)+' of '+cstr(filesize(xp1)-1)+')'); gotoxy(1,wherey-1); + + with xpr1 do begin + xpr.xbstat:=[]; + if (active) then xpr.xbstat:=xpr.xbstat+[xbactive]; + if (isbatch) then xpr.xbstat:=xpr.xbstat+[xbisbatch]; + if (isresume) then xpr.xbstat:=xpr.xbstat+[xbisresume]; + if (xferokcode) then xpr.xbstat:=xpr.xbstat+[xbxferokcode]; + xpr.ckeys:=ckeys; + xpr.descr:=descr; + xpr.acs:=''; + if (sl>0) then xpr.acs:=xpr.acs+'s'+cstr(sl); + if (dsl>0) then xpr.acs:=xpr.acs+'d'+cstr(dsl); + if (ar in ['A'..'Z']) then xpr.acs:=xpr.acs+'f'+ar; +(* if ((minbaud<>300) or (maxbaud<>38400)) then begin + if (minbaud<>300) then xpr.acs:=xpr.acs+'b'+cstr(minbaud div 100); + if (maxbaud<>38400) then xpr.acs:=xpr.acs+'!b'+cstr(maxbaud div 100); + end;*) + xpr.templog:=templog; + xpr.uloadlog:=uloadlog; + xpr.dloadlog:=dloadlog; + (* MUST PUT DSZ PARAMS IN HERE ..... vvv *) + if (ulcmd='XMODEM') then xpr.ulcmd:='dsz port %P speed %B rx %F' else + if (ulcmd='XMODEM-CRC') then xpr.ulcmd:='dsz port %P speed %B rc %F' else + if (ulcmd='YMODEM') then begin + if (isbatch) then + xpr.ulcmd:='dsz port %P speed %B rb -k' + else + xpr.ulcmd:='dsz port %P speed %B rb -k %F'; + end else + xpr.ulcmd:=ulcmd; + if (dlcmd='XMODEM') then xpr.dlcmd:='dsz port %P speed %B sx %F' else + if (dlcmd='XMODEM-CRC') then xpr.dlcmd:='dsz port %P speed %B sx %F' else + if (dlcmd='YMODEM') then begin + if (isbatch) then + xpr.dlcmd:='dsz port %P speed %B sb @%L' + else + xpr.dlcmd:='dsz port %P speed %B sb %F'; + end else + xpr.dlcmd:=dlcmd; + for j:=1 to 6 do begin + xpr.ulcode[j]:=ulcode[j]; + xpr.dlcode[j]:=dlcode[j]; + end; + xpr.envcmd:=envcmd; + xpr.dlflist:=dlflist; + xpr.maxchrs:=maxchrs; + xpr.logpf:=logpf; + xpr.logps:=logps; + xpr.permindx:=i; + for j:=1 to 11 do xpr.res[j]:=0; + end; + + seek(xp,i); write(xp,xpr); + end; + + close(xp1); + close(xp); + rename(xp1,'protocol.old'); + rename(xp,'protocol.dat'); + writeln; + end; + chdir(sp); + end; + 8:begin + ttl('Converting "UPLOADS.DAT'); + chdir(copy(gp,1,length(gp)-1)); + ffile('uploads.dat'); + if (not found) then star('UPLOADS.DAT not found.') + else begin + + assign(ulf1,'uploads.old'); rewrite(ulf1); close(ulf1); erase(ulf1); + assign(ulf1,'uploads.tcp'); rewrite(ulf1); close(ulf1); erase(ulf1); + assign(ulf1,'uploads.dat'); reset(ulf1); + assign(ulf,'uploads.tcp'); rewrite(ulf); + + for i:=0 to filesize(ulf1)-1 do begin + seek(ulf1,i); read(ulf1,ubrd1); + star(' (record #'+cstr(i)+' of '+cstr(filesize(ulf1)-1)+')'); gotoxy(1,wherey-1); + + with ubrd1 do begin + ubrd.name:=name; + ubrd.filename:=filename; + ubrd.dlpath:=dlpath; + ubrd.ulpath:=dlpath; + ubrd.maxfiles:=maxfiles; + if (ubrd.maxfiles>2000) then ubrd.maxfiles:=2000; + ubrd.password:=password; + ubrd.arctype:=arctype; + ubrd.cmttype:=cmttype; + ubrd.fbdepth:=0; + ubrd.fbstat:=[]; + if (noratio) then ubrd.fbstat:=ubrd.fbstat+[fbnoratio]; + if (unhidden) then ubrd.fbstat:=ubrd.fbstat+[fbunhidden]; + ubrd.acs:=''; + if (sl>0) then ubrd.acs:=ubrd.acs+'s'+cstr(sl); + if (dsl>0) then ubrd.acs:=ubrd.acs+'d'+cstr(dsl); + if (ar in ['A'..'Z']) then ubrd.acs:=ubrd.acs+'f'+ar; + if (agereq>1) then ubrd.acs:=ubrd.acs+'a'+cstr(agereq); + ubrd.ulacs:=''; + ubrd.nameacs:=''; + if (namesl>0) then + ubrd.nameacs:=ubrd.nameacs+'s'+cstr(namesl); + ubrd.permindx:=i; + for j:=1 to 6 do ubrd.res[j]:=0; + end; + + seek(ulf,i); write(ulf,ubrd); + end; + close(ulf1); + close(ulf); + rename(ulf1,'uploads.old'); + rename(ulf,'uploads.dat'); + writeln; + end; + chdir(sp); + end; + 12:begin + ttl('Converting "*.BRD" message base info files'); + chdir(copy(gp,1,length(gp)-1)); + ffile('*.brd'); + if not found then star('No *.BRD files present.') + else begin + repeat + s:=dirinfo.name; + + assign(mbasef1,copy(s,1,length(s)-3)+'old'); rewrite(mbasef1); + close(mbasef1); erase(mbasef1); + + assign(mbasef1,copy(s,1,length(s)-3)+'tcp'); rewrite(mbasef1); + close(mbasef1); erase(mbasef1); + + assign(mbasef1,s); reset(mbasef1); + + assign(mbasef,copy(s,1,length(s)-3)+'tcp'); rewrite(mbasef); + + star('Converting "'+s+'" ('+cstr(filesize(mbasef1)-1)+' messages)'); + + for i:=0 to filesize(mbasef1)-1 do begin + seek(mbasef1,i); read(mbasef1,mbase1); + with mbase1 do begin + mbase.title:=title; + if (messagestat=validated1) then mbase.messagestat:=[validated]; + if (messagestat=unvalidated1) then mbase.messagestat:=[unvalidated]; + if (messagestat=deleted1) then mbase.messagestat:=[deleted]; + mbase.message.ltr:=message.ltr; + mbase.message.number:=message.number; + mbase.message.ext:=message.ext; + mbase.owner:=owner; + mbase.date:=mbase1.date; + mbase.nacc:=0; + end; + write(mbasef,mbase); + end; + + close(mbasef); + close(mbasef1); + rename(mbasef,copy(s,1,length(s)-3)+'obr'); + + nfile; + until (not found); + ffile('*.obr'); + while (found) do begin + s:=dirinfo.name; + assign(mbasef1,copy(s,1,length(s)-3)+'brd'); + rename(mbasef1,copy(s,1,length(s)-3)+'old'); + assign(mbasef,s); rename(mbasef,copy(s,1,length(s)-3)+'brd'); + nfile; + end; + end; + chdir(sp); + end; + 13:begin + ttl('Converting "*.MNU" menu files'); + chdir(copy(mp,1,length(mp)-1)); + ffile('*.mnu'); + if not found then star('No *.MNU files present.') + else begin + repeat + + { Converts MNU --> TCP, and only upon successful conversion of + ALL MNU files does "CO" rename all MNU --> OLD, + and TCP --> MNU } + + s:=dirinfo.name; + assign(mf1,copy(s,1,length(s)-3)+'OLD'); rewrite(mf1); close(mf1); + erase(mf1); + + assign(mf1,copy(s,1,length(s)-3)+'TCP'); rewrite(mf1); close(mf1); + erase(mf1); + + if (ioresult<>0) then star('Error renaming "'+s+'" - Nothing done.') + else begin + assign(mf1,s); {$I-} reset(mf1); {$I+} + assign(mf,copy(s,1,length(s)-3)+'TCP'); {$I-} rewrite(mf); {$I+} + + star('Converting "'+s+'"'); + + for i:=1 to 13 do readln(mf1,menuline[i]); + + writeln(mf,menuline[1]); + writeln(mf,''); + writeln(mf,''); + writeln(mf,menuline[2]); + writeln(mf,menuline[3]); + writeln(mf,menuline[4]); + + b1:=(pos('D',menuline[13])<>0); + s1:=''; + if (value(menuline[5])>0) then + if (b1) then s1:=s1+'d'+menuline[5] + else s1:=s1+'s'+menuline[5]; + if (menuline[6][1] in ['A'..'Z']) then s1:=s1+'f'+menuline[6][1]; + writeln(mf,s1); + + writeln(mf,menuline[7]); + writeln(mf,menuline[8]); + + s1:='0'; + if (pos('H',menuline[13])<>0) then s1:='2'; + writeln(mf,s1); + + writeln(mf,menuline[9]); + writeln(mf,menuline[10]); + writeln(mf,menuline[11]); + writeln(mf,menuline[12]); + s1:=menuline[13]; + if (pos('D',s1)<>0) then delete(s1,pos('D',s1),1); + if (pos('H',s1)<>0) then delete(s1,pos('H',s1),1); + writeln(mf,s1); + + repeat + nocopy:=FALSE; + + for i:=1 to 8 do readln(mf1,menuline[i]); + + if (not nocopy) then begin + writeln(mf,menuline[1]); + writeln(mf,menuline[2]); + writeln(mf,menuline[3]); + + b1:=(pos('D',menuline[8])<>0); + b2:=(pos('C',menuline[8])<>0); + s1:=''; + if (value(menuline[4])>0) then + if (b1) then s1:=s1+'d'+menuline[4] + else s1:=s1+'s'+menuline[4]; + if ((b2) and (value(menuline[4])>0) and + (menuline[5][1] in ['A'..'Z'])) then s1:=s1+'|'; + if (menuline[5][1] in ['A'..'Z']) then s1:=s1+'f'+menuline[5][1]; + writeln(mf,s1); + + writeln(mf,menuline[6]); + writeln(mf,menuline[7]); + s1:=menuline[8]; + if (pos('C',s1)<>0) then delete(s1,pos('C',s1),1); + if (pos('D',s1)<>0) then delete(s1,pos('D',s1),1); + if (pos('H',s1)<>0) then delete(s1,pos('H',s1),1) + else s1:=s1+'U'; + writeln(mf,s1); + end; + until (eof(mf1)); + + close(mf); + close(mf1); + end; + nfile; + until (not found); + + ffile('*.TCP'); + repeat + s:=dirinfo.name; + assign(mf1,copy(s,1,length(s)-3)+'MNU'); + rename(mf1,copy(s,1,length(s)-3)+'OLD'); + assign(mf,s); + rename(mf,copy(s,1,length(s)-3)+'MNU'); + nfile; + until (not found); + + end; + chdir(sp); + end; + end; +end; + +procedure convert(xx:integer); +var s:astr; + i,j,k:integer; + c:char; +begin + case xx of + 0 :c:='S'; + 1..9 :c:=chr(xx+48); + 10..20:c:=chr(xx+55); + end; + if (needc(c)) then + if (back) then bconvert(xx) else fconvert(xx); +end; + +begin + if (standard_conversion) then ver:=s_ver; + + infield_out_fgrd:=15; + infield_out_bkgd:=1; + infield_inp_fgrd:=0; + infield_inp_bkgd:=7; + + getdir(0,sp); + aw:=FALSE; + didit:=FALSE; + if paramcount>0 then if allcaps(paramstr(1))='C' then aw:=TRUE; + savx:=wherex; savy:=wherey; + setwindow(wind,1,1,80,25,7,0,0); + clrscr; + textbackground(1); textcolor(15); clreol; + write(' Telegard Conversion for '+ver1+' ¯¯¯¯¯¯¯¯¯ '+ver); + textbackground(0); + window(1,2,80,25); clrscr; + tc(14); + writeln; + writeln('This program is provided to add/modify/create files used by Telegard to'); + writeln('make it 100% functional under the '+ver+' environment. This file MUST'); + writeln('be ran in the directory in which STATUS.DAT is found, and STATUS.DAT MUST'); + writeln('be in '+ver1+' format!!! If STATUS.DAT is not in the current directory,'); + writeln('or if you have already ran this program (STATUS.DAT has already been'); + writeln('converted), this program will abort.'); + writeln; + tc(9); write('Hit any key to continue ( to abort NOW) : '); + repeat until keypressed; + c:=readkey; + if (c=#27) then ee('ABORTED CONVERSION'); + + repeat + clrscr; + fvers; + + if (not aw) then begin + writeln; + star('WARNING! This conversion program needs APPROXIMATELY'); + star(cstrl(needs)+' bytes free on your main BBS drive!!!!!!!!'); + writeln; + star('You currently have '+cstrl(freek(0)*1024)+' bytes left on the current drive.'); + writeln; + star('If you DO NOT have enough space left, your drive will probably'); + star('explode, and your house will burn to the ground. If you are'); + star('skeptical of this, feel free to call Garfield, SysOp of Electric'); + star('Eye ][ BBS (313/776-8928), who can tell you how bad HIS messed up'); + star('when he converted from 1.6d3 --> 1.6e1 with only 500k!'); + writeln; + if (not l_pynq('Proceed? ')) then ee('Aborted conversion'); + end; + + clrscr; + writeln; + if aw then begin + for i:=0 to 13 do begin + if (i>=1) and (i<=9) then c:=chr(i+48) else + if (i=0) then c:='S' else + if (i>=10) then c:=chr(i+55); + if needc(c) then begin + tc(9); write('['+cstr(i)+'] '); + if i<10 then write(' '); + tc(11); + case i of + 0:write('(S)tatus.dat'); + 1:write('names.lst'); + 2:write('user.lst'); + 3:write('boards.dat'); + 4:write('email.dat'); + 5:write('gfiles.dat'); + 6:write('protocol.dat'); + 7:write('shortmsg.dat'); + 8:write('uploads.dat'); + 9:write('voting.dat'); + 10:write('zlog.dat'); + 11:write(gp+'*.dir'); + 12:write(gp+'*.brd'); + 13:write(mp+'*.mnu'); + end; + writeln; + end; + end; + writeln; + tc(14); write('Enter # to convert, [A]ll or [Q]uit :'); + tc(9); readln(a); a:=allcaps(a); + + j:=value(a); + end else + a:='A'; + + if (j=0) then + if (copy(a,1,1)='S') then j:=0 else j:=-1; + + if (copy(a,1,1)<>'Q') or ((j>=0) and (j<=13)) then begin + writeln; + if aw then begin + tc(14); write('[1]Convert to '+ver+' - [2]Convert back to '+ver1+' : '); + tc(9); readln(b); b:=allcaps(b); + h:=value(b); + end else + h:=1; + + if (h in [1,2]) then begin + clrscr; tc(15); + back:=FALSE; + if h=2 then back:=TRUE; + if back then begin + tc(31); + writeln('Convert '+ver+' ¯¯¯¯¯¯¯¯¯ '+ver1); + end else + writeln('Convert '+ver1+' ¯¯¯¯¯¯¯¯¯ '+ver); + writeln; + tc(4); write('WARNING: '); + tc(12); + if back then writeln('If files are not in version '+ver+' format,') else + writeln('If files are NOT in version '+ver1+' format,'); + writeln('the data will be COMPLETELY LOST *FOREVER*!!'); + writeln; + writeln; + tc(14); writeln('ARE YOU ABSOLUTELY SURE?'); + writeln('(Enter "YES" in ALL CAPS, without quotes, if you are...)'); + write(':'); + readln(b); + + if b='YES' then begin + clrscr; + + if copy(a,1,1)<>'A' then convert(j) + else begin + for i:=0 to 13 do convert(i); +{ ttl('Moving new files into their directories'); + smovefile('protocol.dat',systat.gfilepath); + smovefile('sysfunc.ans',systat.afilepath);} + end; + didit:=TRUE; + end; + end; + end; + if (not aw) then a:='Q'; + until copy(a,1,1)='Q'; + + writeln; + star('Press any key...'); c:=readkey; + clrscr; + removewindow(wind); + + if didit then begin + setwindow(wind,20,11,59,17,9,1,1); + clrscr; tc(15); + gotoxy(4,3); + write('Thank you for choosing Telegard!'); + CursorOff; delay(1500); CursorOn; + removewindow(wind); + end; + gotoxy(savx,savy); + chdir(sp); +end. diff --git a/cuser.pas b/cuser.pas new file mode 100644 index 0000000..e3987ea --- /dev/null +++ b/cuser.pas @@ -0,0 +1,794 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit cuser; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common; + +procedure cstuff(which,how:byte; var user:userrec); + +implementation + +(****************************************************************************** + procedure: cstuff(which,how:byte; var user:userrec); +--- + purpose: Inputs user information. +--- + variables passed: + + which- 1:Address 6:Occupation 11:Screen size + 2:Age 7:User name 12:Sex + 3:ANSI status 8:Phone # 13:BBS reference + 4:City & State 9:Password 14:Zip code + 5:Computer type 10:Real name + + how- 1:New user logon in process + 2:Menu edit command + 3:Called by the user-list editor + + user- User information to modify +******************************************************************************) + +var callfromarea:integer; + +procedure cstuff(which,how:byte; var user:userrec); +var done,done1:boolean; + try:integer; + fi:text; + s:astr; + i:integer; + + procedure findarea; + var c:char; + begin + print('Are you calling from:'); + print(' 1. United States'); + print(' 2. Canada'); + print(' 3. Other country'); + nl; + prt('Select (1-3) : '); onek(c,'123'); + if (hangup) then exit; + callfromarea:=ord(c)-48; + done1:=TRUE; + end; + + procedure doaddress; + begin + if (how=3) then print('Enter new mailing address.') + else print('Enter your mailing address: [APT#]'); + prt(':'); + if (how=3) then inputl(s,30) else inputcaps(s,30); + if (s<>'') then begin + user.street:=s; + done1:=TRUE; + end; + end; + + procedure doage; + var b:byte; + s:astr; + + function numsok(s:astr):boolean; + var i:integer; + begin + numsok:=FALSE; + for i:=1 to 8 do + if not ((s[i] in ['0'..'9']) or (i=3) or (i=6)) then exit; + numsok:=TRUE; + end; + + begin + if (how=3) then prompt('Enter date of birth (mm/dd/yy) : ') + else begin + sprint('^301^5=January ^304^5=April ^307^5=July ^310^5=October'); + sprint('^302^5=February ^305^5=May ^308^5=August ^311^5=November'); + sprint('^303^5=March ^306^5=June ^309^5=September ^312^5=December'); + nl; + prt('Enter your date of birth (mm/dd/yy) : '); + end; + cl(3); input(s,8); + if ((length(s)=8) and (s[3]='/') and (s[6]='/')) then + if (numsok(s)) then + if (ageuser(s)<3) then + sprint(#3#7+'Isn''t '+cstr(ageuser(s))+' years old a little YOUNG???') + else begin + user.bday:=s; + done1:=TRUE; + end; + if ((not done1) and (how=1)) then sprint(#3#7+'Sorry, try again!'); + end; + + procedure doansi; + begin + pr(#27+'[0;1;5;33;40mANSI test'); tc(14+128); writeln('ANSI test'); + nl; + if pynq('Do you have ANSI (are the above words blinking)? ') then begin + user.ac:=user.ac+[ansi]; + if pynq('Do you have a color monitor? ') then user.ac:=user.ac+[color]; + end; + done1:=TRUE; + end; + + procedure docitystate; + var s,s1,s2:astr; + begin + case how of + 2:findarea; + 3:callfromarea:=1; + end; + if (callfromarea<>3) then begin + if (how=3) then begin + print('Enter new city & state: '); + prt(':'); inputl(s,30); + if (s<>'') then user.citystate:=s; + done1:=TRUE; + exit; + end; + case callfromarea of + 1:print('City & State entry.'); + 2:print('City & Province entry.'); + end; + nl; + if (callfromarea=1) then s1:='state' else s1:='province'; + print('First enter your city name (do not include '+s1+'):'); + prt(':'); inputcaps(s1,26); + while (copy(s1,1,1)=' ') do s1:=copy(s1,2,length(s1)-1); + while (copy(s1,length(s1),1)=' ') do s1:=copy(s1,1,length(s1)-1); + nl; + if (length(s1)<2) then begin + sprint(#3#7+'Why do I find it hard to believe'); + sprint(#3#7+'that that is '+#3#5+'not'+#3#7+' a real city?'); + nl; + if (callfromarea=1) then s2:='Detroit' else s2:='Toronto'; + sprint(#3#7+'Example: "'+s2+'" is a real city.'); + exit; + end; + if (pos(',',s1)<>0) then begin + if (callfromarea=1) then s2:='state' else s2:='province'; + sprint(#3#7+'NO COMMAS! Don''t enter your '+s2+' YET,'); + sprint(#3#7+'just enter your CITY!!! I''ll ask for your'); + sprint(#3#7+allcaps(s2)+' as soon as I know your CITY!!!'); + nl; + if (callfromarea=1) then s2:='Detroit' else s2:='Toronto'; + sprint(#3#7+'Example: "'+s2+'" is a city!'); + exit; + end; + if (callfromarea=1) then s2:='state' else s2:='province'; + prompt('Now enter your 2-letter '+s2+' abbreviation: '); + cl(3); input(s2,2); + nl; + if (length(s2)<2) then begin + sprint(#3#0+'TWO '+#3#7+'characters. '+#3#0+'TWO '+#3#7+'characters. Can''t you count?'); + sprint(#3#7+'(Hint: notice the word "'+#3#0+'TWO'+#3#7+'")'); + exit; + end; + user.citystate:=s1+', '+s2; + done1:=TRUE; + end else begin + print('First enter your city name, and nothing else:'); + prt(':'); inputcaps(s1,26); + if (length(s1)<2) then exit; + nl; + print('Now enter your country name:'); + prt(':'); inputcaps(s2,26); + if (length(s2)<2) then exit; + nl; + s:=s1+', '+s2; + print('Final result: "'+s+'"'); + if (length(s)>30) then begin + print('Too long! Max total length is 30 characters.'); + print('Find some way to abbreviate.'); + exit; + end; + user.citystate:=s; + done1:=TRUE; + end; + end; + + procedure docomputer; + var fp:text; + ctyp:array[1..31] of string[30]; + i,n:integer; + s,s1:astr; + c:char; + abort,next,other,cexist:boolean; + begin + other:=TRUE; cexist:=FALSE; + assign(fp,systat.afilepath+'computer.txt'); + {$I-} reset(fp); {$I+} + if (ioresult=0) then begin + cexist:=TRUE; + other:=FALSE; i:=0; + repeat + inc(i); + readln(fp,ctyp[i]); + until eof(fp) or (i=30); + close(fp); + n:=i+1; ctyp[n]:='Other'; abort:=FALSE; + for i:=1 to n do begin + s:=#3#1+mln(cstr(i)+'.',3)+ctyp[i]; + if (odd(i)) then s1:=s else printacr(mln(s1,33)+s,abort,next); + end; + if (odd(n)) then printacr(s1,abort,next); + nl; + if (how=3) then prt('Enter new computer type: ') + else prt('Enter your computer type: '); + input(s,2); i:=value(s); + if (i>=1) and (i'') then begin + user.computer:=s; + done1:=TRUE; + end; + end; + s:=''; i:=1; + while (i<=length(user.computer)) do begin + if (user.computer[i]<>#3) then s:=s+user.computer[i] else inc(i); + inc(i); + end; + end; + + procedure dojob; + begin + if (how=3) then print('Enter new occupation.') + else print('Enter your occupation:'); + prt(':'); + if (how=3) then inputl(s,40) else inputcaps(s,40); + if (s<>'') then begin + user.occupation:=s; + done1:=TRUE; + end; + end; + + procedure doname; + var i:integer; + s1,s2:astr; + sfo:boolean; + sr:smalrec; + begin + if (systat.allowalias) then begin + print('Enter your handle, or your first & last'); + print('name if you don''t want to use one.') + end else + print('Enter your first & last name. Handles are NOT ALLOWED!'); + prt(':'); input(s,36); + done1:=TRUE; + nl; + if ((not (s[1] in ['A'..'Z','?'])) or (s='')) then done1:=FALSE; + sfo:=(filerec(sf).mode<>fmclosed); + if (not sfo) then reset(sf); + for i:=1 to filesize(sf)-1 do begin + seek(sf,i); read(sf,sr); + if (sr.name=s) then begin + done1:=FALSE; + sprint(#3#7+'That name is already being used.'); + end; + end; + if (not sfo) then close(sf); + assign(fi,systat.afilepath+'trashcan.txt'); + {$I-} reset(fi); {$I+} + if (ioresult=0) then begin + s2:=' '+s+' '; + while not eof(fi) do begin + readln(fi,s1); + if s1[length(s1)]=#1 then s1[length(s1)]:=' ' else s1:=s1+' '; + s1:=' '+s1; + for i:=1 to length(s1) do s1[i]:=upcase(s1[i]); + if pos(s1,s2)<>0 then begin + sprint(#3#7+'"'+copy(s1,pos(s1,s2),length(s1))+'" may not be used!'); + done1:=FALSE; + end; + end; + close(fi); + end; + if (not done1) and (not hangup) then begin + sprint(#3#7+^G'Sorry, can''t use that name.'); + inc(try); + sl1('Unacceptable name : '+s); + end; + if (try>=3) then hangup:=TRUE; + if (done1) then user.name:=s; + if ((done) and (how=1) and (not systat.allowalias)) then + user.realname:=caps(s); + end; + + procedure dophone; + begin + case how of + 2:findarea; + 3:callfromarea:=1; + end; + if (how=3) then print('Enter new VOICE phone number:') + else print('Enter your VOICE phone number:'); + if (((how=1) and (callfromarea=3)) or (how=3)) then begin + prt(':'); input(s,12); + if (length(s)>5) then begin user.ph:=s; done1:=TRUE; end; + end else begin + print(' ###-###-####.'); + prt(':'); input(s,12); + if (length(s)=12) and (s[4]='-') and (s[8]='-') then begin + user.ph:=s; + done1:=TRUE; + end else + if (how=1) then sprint(#3#7+'Please enter it correctly!'); + end; + end; + + procedure dopw; + var s:astr; + begin + case how of + 1:begin + print('Enter a password that you will use to log on again.'); + print('It must be between 4 and 20 characters in length.'); + prt(':'); input(s,20); + if (length(s)<4) then + sprint(#3#7+'Must be at least 4 characters long.') + else + if (length(s)>20) then + sprint(#3#7+'Must be less than 20 characters long.') + else begin + nl; + sprint(#3#3+'Your password: '+#3#5+s); + done1:=pynq('Is this correct? '); + if (done1) then user.pw:=s; + end; + end; + 2:begin + sprint(#3#5+'For security reasons, when changing passwords'); + sprint(#3#5+'you must first enter your old password.'); + nl; + sprompt(#3#0+'User password : '+#3#5); input(s,20); + if (s<>user.pw) then sprint(^G+#3#7+'>> INCORRECT PASSWORD <<') + else begin + nl; + print('Your new password must be 4-20 chrs in length.'); + nl; + repeat + prt('New password: '); mpl(20); input(s,20); + nl; + until (((length(s)>=4) and (length(s)<=20)) or (s='') or (hangup)); + if (s<>'') then begin + nl; nl; + sprint(#3#3+'New Password: "'+#3#5+s+#3#3+'"'); + if pynq('Are you SURE this is what you want? ') then begin + if (not hangup) then user.pw:=s; + sysoplog('Changed password.'); + done1:=TRUE; + end else + print('Aborted.'); + end else + print('Aborted.'); + end; + nl; + end; + 3:begin + print('Enter new password.'); prt(':'); input(s,20); + if (s<>'') then begin + done1:=TRUE; + user.pw:=s; + end; + end; + end; + end; + + procedure dorealname; + var i:integer; + begin + if ((how=1) and (not systat.allowalias)) then begin + user.realname:=caps(user.name); + done1:=TRUE; + exit; + end; + if (how=3) then print('Enter new REAL first & last name, or') + else print('Enter your REAL first & last name, or'); + print('enter "=" if same as your user name.'); + prt(':'); + if (how=3) then inputl(s,36) else inputcaps(s,36); + if (s='=') then s:=caps(user.name); + while copy(s,1,1)=' ' do s:=copy(s,2,length(s)-1); + while copy(s,length(s),1)=' ' do s:=copy(s,1,length(s)-1); + if (pos(' ',s)=0) and (how<>3) then begin + print('Enter it correctly! First AND last name please!'); + s:=''; + end; + if (s<>'') then begin + user.realname:=s; + done1:=TRUE; + end; + end; + + procedure doscreen; + var v:string; + bb:byte; + begin + if (how=1) then begin + user.linelen:=systat.linelen; + user.pagelen:=systat.pagelen; + end; + prt('How many columns wide is your screen (32-132) ['+ + cstr(thisuser.linelen)+'] : '); + ini(bb); if (not badini) then user.linelen:=bb; + prt('Number of lines per page (4-50) ['+cstr(thisuser.pagelen)+'] : '); + ini(bb); if (not badini) then user.pagelen:=bb; + if (user.pagelen>50) then user.pagelen:=50; + if (user.pagelen<4) then user.pagelen:=4; + if (user.linelen>132) then user.linelen:=132; + done1:=TRUE; + end; + + procedure dosex; + var c:char; + begin + if (how=3) then begin + prt('New sex (M,F) : '); + onek(c,'MF '^M); + if (c in ['M','F']) then user.sex:=c; + end else begin + user.sex:=#0; + repeat + prt('Your sex (M,F) ? '); + onek(user.sex,'MF'^M); + if (user.sex=^M) then begin + nl; + sprint(#3#7+'Don''t know your own sex, eh? Better see a doctor!'); + nl; + end; + until ((user.sex in ['M','F']) or (hangup)); + end; + done1:=TRUE; + end; + + procedure dowherebbs; + begin + if (how=3) then print('Enter new BBS reference.') + else begin + print('Where did you hear about this BBS from? (be specific;'); + print('do not say, for example, "some guy on another board")'); + end; + prt(':'); + if (how=3) then inputl(s,40) else inputcaps(s,40); + if (s<>'') then begin user.wherebbs:=s; done1:=TRUE; end; + end; + + procedure dozipcode; + begin + case how of + 2:findarea; + 3:callfromarea:=1; + end; + case callfromarea of + 1:begin + if (how=3) then + print('Enter new postal code (##### or #####-####)') + else begin + print('Enter your zipcode (9 digit if available)'); + print(' ##### or #####-####'); + end; + prt(':'); input(s,10); + if (length(s) in [5,10]) then begin user.zipcode:=s; done1:=TRUE; end; + end; + 2:begin + print('Enter your zipcode (@#@#@# format -- "@"=letter "#"=number)'); + prt(':'); input(s,6); + if ((length(s)=6) and + (s[1] in ['A'..'Z']) and (s[2] in ['0'..'9']) and + (s[3] in ['A'..'Z']) and (s[4] in ['0'..'9']) and + (s[5] in ['A'..'Z']) and (s[6] in ['0'..'9'])) then + done1:=TRUE + else + print('Illegal format!'); + end; + 3:begin + print('Enter your postal code:'); + prt(':'); input(s,10); + if (length(s)>2) then begin user.zipcode:=s; done1:=TRUE; end; + end; + end; + end; + + procedure forwardmail; + var u:userrec; + s:astr; + i:integer; + b,ufo:boolean; + begin + nl; + print('If you forward your mail, all mail'); + print('addressed to you will go to that person'); + print('Now enter the user''s number, or just'); + print('hit to deactivate mail forwarding.'); + prt(':'); input(s,4); + i:=value(s); + nl; + if (i=0) then begin + user.forusr:=0; + print('Forwarding deactivated.'); + end else begin + ufo:=(filerec(uf).mode<>fmclosed); + if (not ufo) then reset(uf); + b:=TRUE; + if (i>=filesize(uf)) then b:=FALSE + else begin + seek(uf,i); read(uf,u); + if (u.deleted) or (nomail in u.ac) then b:=FALSE; + end; + if (i=usernum) then b:=FALSE; + if (b) then begin + user.forusr:=i; + print('Forwarding set to: '+caps(u.name)+' #'+cstr(i)); + sysoplog('Started forwarding mail to '+caps(u.name)+' #'+cstr(i)); + end else + print('Sorry, can''t forward to that user.'); + if (not ufo) then close(uf); + end; + end; + + procedure mailbox; + begin + if (nomail in user.ac) then begin + user.ac:=user.ac-[nomail]; + sprint(#3#5+'Mailbox now open.'); + sysoplog('Opened mailbox.'); + end else + if (user.forusr<>0) then begin + user.forusr:=0; + print('Mail no longer forwarded.'); + sysoplog('Stopped forwarding mail.'); + end else begin + if pynq('Do you want to close your mailbox? ') then begin + user.ac:=user.ac+[nomail]; + sprint(#3#5+'Mailbox now closed.'); + sprint(#3#5+'You >CAN NOT< recieve mail now.'); + sysoplog('Closed mailbox.'); + end else + if pynq('Do you want your mail forwarded? ') then forwardmail; + end; + done1:=TRUE; + end; + + procedure tog_ansi; + var c:char; + begin + prompt('Which emulation? (1) TTY (none), (2) ANSI, (3) AVATAR : '); + cl(3); onek(c,'123'); + user.ac:=user.ac-[ansi]; + user.ac:=user.ac-[avatar]; + case c of + '2':user.ac:=user.ac+[ansi]; + '3':user.ac:=user.ac+[avatar]; + end; +(* + if (ansi in user.ac) then begin + user.ac:=user.ac-[ansi]; + print('ANSI disabled.'); + end else begin + user.ac:=user.ac+[ansi]; + print('ANSI activated.'); + end; +*) + done1:=TRUE; + end; + + procedure tog_color; + begin + if (color in user.ac) then begin + user.ac:=user.ac-[color]; + print('ANSI color disabled.'); + end else begin + user.ac:=user.ac+[color]; + print('ANSI color activated.'); + end; + done1:=TRUE; + end; + + procedure tog_pause; + begin + if (pause in user.ac) then begin + user.ac:=user.ac-[pause]; + print('No pause on screen.'); + end else begin + user.ac:=user.ac+[pause]; + print('Pause on screen active.'); + end; + done1:=TRUE; + end; + + procedure tog_input; + begin + if (onekey in user.ac) then begin + user.ac:=user.ac-[onekey]; + print('Full line input.'); + end else begin + user.ac:=user.ac+[onekey]; + print('One key input.'); + end; + done1:=TRUE; + end; + + procedure tog_clsmsg; + begin + if (user.clsmsg=1) then begin + user.clsmsg:=2; + print('Clear screen for messages OFF.'); + end else begin + user.clsmsg:=1; + print('Clear screen for messages ON.'); + end; + done1:=TRUE; + end; + + procedure tog_avadj; + begin + if (user.avadjust=2) then begin + user.avadjust:=1; + print('AVATAR color adjustment disabled.'); + end else begin + user.avadjust:=2; + print('AVATAR color adjustment enabled.'); + end; + done1:=TRUE; + end; + + procedure tog_expert; + begin + if (novice in user.ac) then begin + user.ac:=user.ac-[novice]; + chelplevel:=1; + print('Expert mode ON.'); + end else begin + user.ac:=user.ac+[novice]; + chelplevel:=2; + print('Expert mode OFF.'); + end; + done1:=TRUE; + end; + + procedure chcolors; + var s:astr; + c,c1,c2:integer; + ch:char; + mcol,ocol:byte; + ctyp,done:boolean; + + function colo(n:integer):astr; + begin + case n of + 0:colo:='Black'; + 1:colo:='Blue'; + 2:colo:='Green'; + 3:colo:='Cyan'; + 4:colo:='Red'; + 5:colo:='Magenta'; + 6:colo:='Yellow'; + 7:colo:='White'; + end; + end; + + function dt(n:integer):astr; + var s:astr; + begin + s:=colo(n and 7)+' on '+colo((n shr 4) and 7); + if (n and 8)<>0 then s:=s+', High Intensity'; + if (n and 128)<>0 then s:=s+', Blinking'; + dt:=s; + end; + + function stf(n:integer):astr; + var s:astr; + begin + case n of + 0:s:='Other'; + 1:s:='Default'; + 2:s:='Unused'; + 3:s:='Yes/No'; + 4:s:='Prompts'; + 5:s:='Note'; + 6:s:='Input line'; + 7:s:='Y/N question'; + 8:s:='Blinking'; + 9:s:='Other'; + end; + stf:=cstr(n)+'. '+mln(s,20); + end; + + procedure liststf; + var c:integer; + begin + nl; + for c:=0 to 9 do begin + setc(7); prompt(stf(c)); + setc(user.cols[ctyp][c]); print(dt(user.cols[ctyp][c])); + end; + end; + + begin + ctyp:=color in user.ac; + setc(7); + if (ctyp) then print('Set multiple colors.') else print('Set B&W colors.'); + ch:='?'; done:=FALSE; + repeat + case ch of + 'Q':done:=TRUE; + 'L':liststf; + '0'..'9':begin + nl; setc(7); print('Current:'); nl; + c1:=value(ch); + setc(7); prompt(stf(c1)); + setc(user.cols[ctyp][c1]); print(dt(user.cols[ctyp,c1])); + nl; setc(7); print('Colors:'); nl; + for c:=0 to 7 do begin + setc(7); prompt(cstr(c)+'. '); setc(c); prompt(mln(colo(c),12)); + setc(7); prompt(mrn(cstr(c+8),2)+'. '); setc(c+8); print(mln(colo(c)+'!',9)); + end; + ocol:=user.cols[ctyp][c1]; nl; + prt('Foreground: '); input(s,2); + if (s='') then mcol:=ocol and 7 else mcol:=value(s); + prt('Background: '); input(s,2); + if (s='') then + mcol:=mcol or (ocol and 112) + else + mcol:=mcol or (value(s) shl 4); + if pynq('Blinking? ') then mcol:=mcol or 128; + nl; setc(7); prompt(stf(c1)); setc(mcol); print(dt(mcol)); nl; + if pynq('Is this correct? ') then user.cols[ctyp][c1]:=mcol; + end; + end; + if (not done) then begin + nl; prt('Colors: (0-9) (L)ist (Q)uit :'); onek(ch,'QL0123456789'); + end; + until done or hangup; + done1:=TRUE; + end; + + procedure checkwantpause; + begin + if pynq('Should screen pausing be active? ') then + user.ac:=user.ac+[pause] + else + user.ac:=user.ac-[pause]; + done1:=TRUE; + end; + + procedure ww(www:integer); + begin + nl; + case www of + 1:doaddress; 2:doage; 3:doansi; + 4:docitystate; 5:docomputer; 6:dojob; + 7:doname; 8:dophone; 9:dopw; + 10:dorealname; 11:doscreen; 12:dosex; + 13:dowherebbs; 14:dozipcode; 15:mailbox; + 16:tog_ansi; 17:tog_color; 18:tog_pause; + 19:tog_input; 20:tog_clsmsg; 21:chcolors; + 22:tog_expert; 23:findarea; 24:checkwantpause; + 25:tog_avadj; + end; + end; + +begin + try:=0; done1:=FALSE; + case how of + 1:repeat ww(which) until (done1) or (hangup); + 2,3:begin + ww(which); + if not done1 then print('Function aborted!'); + end; + end; +end; + +end. diff --git a/cx.pas b/cx.pas new file mode 100644 index 0000000..38eb08d --- /dev/null +++ b/cx.pas @@ -0,0 +1,8 @@ +uses dos; + +{$I rec30} + +begin + writeln(sizeof(userrec)); +end. + diff --git a/doors.pas b/doors.pas new file mode 100644 index 0000000..a22a045 --- /dev/null +++ b/doors.pas @@ -0,0 +1,394 @@ +(*****************************************************************************) +(*> <*) +(*> DOORS .PAS - Written by Eric Oman <*) +(*> <*) +(*> Online door procedures. <*) +(*> <*) +(*****************************************************************************) +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit doors; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + execbat, + common; + +function process_door(s:astr):astr; +procedure write_dorinfo1_def(rname:boolean); { RBBS-PC DORINFO1.DEF } +procedure write_door_sys(rname:boolean); { GAP DOOR.SYS } +procedure write_chain_txt; { WWIV CHAIN.TXT } +procedure write_callinfo_bbs(rname:boolean); { Wildcat! CALLINFO.BBS } +procedure write_sfdoors_dat(rname:boolean); { Spitfire SFDOORS.DAT } +procedure dodoorfunc(kind:char; cline:astr); + +implementation + +function timestr:astr; +var i:astr; +begin + {str(nsl/60,i);} + {i:=copy(i,2,length(i));} + {i:=copy(i,1,pos('.',i)-1);} + i:=cstrr(nsl/60,10); + timestr:=i; +end; + +function process_door(s:astr):astr; +var i:integer; + sda,namm:astr; + sdoor:string[255]; +begin + namm:=caps(thisuser.realname); + sdoor:=''; + for i:=1 to length(s) do begin + if copy(s,i,1)='@' then begin + sda:=''; + case upcase(s[i+1]) of + 'B':if spd<>'KB' then sda:=spd else sda:='0'; + 'D':begin + loaduboard(fileboard); + sda:=memuboard.dlpath; + end; + 'F':sda:=copy(namm,1,pos(' ',namm)-1); + 'G':if okansi then sda:='1' else sda:='0'; + 'I':begin + loaduboard(fileboard); + sda:=systat.gfilepath; + if (copy(sda,length(sda),1)<>'\') then sda:=sda+'\'; + sda:=sda+memuboard.filename+'.DIR'; + end; + 'L':begin + if (pos(' ',namm)=0) then sda:=namm else + sda:=copy(namm,pos(' ',namm)+1,length(namm)); + end; + 'N':sda:=caps(thisuser.name); + 'T':sda:=timestr; + 'R':sda:=(copy(nam,pos('#',nam)+1,length(nam))); + end; + sdoor:=sdoor+sda; + inc(i); + end + else sdoor:=sdoor+copy(s,i,1); + end; + process_door:=sdoor; +end; + +procedure write_dorinfo1_def(rname:boolean); (* RBBS-PC's DORINFO1.DEF *) +var fp:text; + first,last:astr; + s:astr; +begin + assign(fp,'dorinfo1.def'); + rewrite(fp); + writeln(fp,stripcolor(systat.bbsname)); + first:=copy(systat.sysopname,1,pos(' ',systat.sysopname)-1); + last:=copy(systat.sysopname,length(first)+2,length(systat.sysopname)); + writeln(fp,first); + writeln(fp,last); + if spd='KB' then writeln(fp,'COM0') else writeln(fp,'COM'+cstr(modemr.comport)); + if spd='KB' then s:='0' else s:=spd; + writeln(fp,s+' BAUD,N,8,1'); + writeln(fp,'0'); + if (rname) then begin + if pos(' ',thisuser.realname)=0 then begin + first:=thisuser.realname; + last:=''; + end else begin + first:=copy(thisuser.realname,1,pos(' ',thisuser.realname)-1); + last:=copy(thisuser.realname,length(first)+2,length(thisuser.realname)); + end; + first:=allcaps(first); + last:=allcaps(last); + end else begin + if pos(' ',thisuser.name)=0 then begin + first:=thisuser.name; + last:=''; + end else begin + first:=copy(thisuser.name,1,pos(' ',thisuser.name)-1); + last:=copy(thisuser.name,length(first)+2,length(thisuser.name)); + end; + end; + writeln(fp,caps(first)); + writeln(fp,caps(last)); + writeln(fp,thisuser.citystate); + if (ansi in thisuser.ac) then writeln(fp,'1') else writeln(fp,'0'); + writeln(fp,thisuser.sl); + s:=timestr; + if length(s)>3 then s:='999'; + writeln(fp,s); + writeln(fp,'0'); + close(fp); +end; + +procedure write_door_sys(rname:boolean); (* GAP's DOOR.SYS *) +var fp:text; + i:integer; + s:astr; +begin + assign(fp,'door.sys'); + rewrite(fp); + if spd<>'KB' then writeln(fp,'COM'+cstr(modemr.comport)+':') else writeln(fp,'COM0:'); + if spd<>'KB' then writeln(fp,spd) else writeln(fp,cstr(modemr.waitbaud)); + writeln(fp,' 8'); + writeln(fp,' 1'); + writeln(fp,' N'); + if wantout then writeln(fp,' Y') else writeln(fp,' N'); + writeln(fp,' Y'); + if sysop then writeln(fp,' Y') else writeln(fp,' N'); + if alert in thisuser.ac then writeln(fp,' Y') else writeln(fp,' N'); + if (rname) then writeln(fp,thisuser.realname) else writeln(fp,thisuser.name); + writeln(fp,thisuser.citystate); + writeln(fp,copy(thisuser.ph,1,3)+' '+copy(thisuser.ph,5,8)); + writeln(fp,copy(thisuser.ph,1,3)+' '+copy(thisuser.ph,5,8)); + writeln(fp,thisuser.pw); + writeln(fp,cstr(thisuser.sl)); + writeln(fp,cstr(thisuser.loggedon)); + writeln(fp,thisuser.laston); + writeln(fp,cstrl(trunc(nsl))); + writeln(fp,cstr(trunc(nsl) div 60)); + if okansi then writeln(fp,'GR') else writeln(fp,'NG'); + writeln(fp,cstr(thisuser.pagelen)); + if novice in thisuser.ac then writeln(fp,' N') else writeln(fp,' Y'); + s:=''; + for i:=1 to 7 do + if chr(i+64) in thisuser.ar then s:=s+cstr(i); + writeln(fp,s); + writeln(fp,'7'); + writeln(fp,'12/31/99'); + writeln(fp,' '+cstr(usernum)); + writeln(fp,' X'); + writeln(fp,' '+cstr(thisuser.uploads)); + writeln(fp,' '+cstr(thisuser.downloads)); + writeln(fp,' '+cstr(trunc(thisuser.dk))); + writeln(fp,' 999999'); + close(fp); +end; + +procedure write_chain_txt; +var fp:text; + ton,tused:real; + s:string[20]; + + function bo(b:boolean):astr; + begin + if b then bo:='1' else bo:='0'; + end; + +begin + assign(fp,'chain.txt'); + rewrite(fp); + with thisuser do begin + writeln(fp,usernum); { user number } + writeln(fp,name); { user name } + writeln(fp,realname); { real name } + writeln(fp,''); { "call sign" ? } + writeln(fp,ageuser(bday)); { age } + writeln(fp,sex); { sex } + str(credit:7,s); writeln(fp,s+'.00'); { credit } + writeln(fp,laston); { laston date } + writeln(fp,linelen); { # screen columns } + writeln(fp,pagelen); { # screen rows } + writeln(fp,sl); { SL } + writeln(fp,bo(so)); { is he a SysOp? } + writeln(fp,bo(cso)); { is he a CoSysOp? } + writeln(fp,bo(okansi)); { is graphics on? } + writeln(fp,bo(incom)); { is remote? } + str(nsl:10:2,s); writeln(fp,s); { time left (sec) } + writeln(fp,systat.gfilepath); { gfiles path } + writeln(fp,systat.gfilepath); { data path } + writeln(fp,'SYSOP.LOG'); { SysOp log filespec } + s:=spd; if (s='KB') then s:='0'; { baud rate } + writeln(fp,s); + writeln(fp,modemr.comport); { COM port } + writeln(fp,stripcolor(systat.bbsname)); { system name } + writeln(fp,systat.sysopname); { SysOp's name } + with timeon do begin + ton:=hour*3600.0+min*60.0+sec; + tused:=timer-ton; + if (tused<0) then tused:=tused+3600.0*24.0; + end; + writeln(fp,trunc(ton)); { secs on f/midnight } + writeln(fp,trunc(tused)); { time used (sec) } + writeln(fp,uk); { upload K } + writeln(fp,uploads); { uploads } + writeln(fp,dk); { download K } + writeln(fp,downloads); { downloads } + writeln(fp,'8N1'); { COM parameters } + end; + close(fp); +end; + +procedure write_callinfo_bbs(rname:boolean); +var fp:text; + s:astr; + + function bo(b:boolean):astr; + begin + if b then bo:='1' else bo:='0'; + end; + +begin + assign(fp,'callinfo.bbs'); + rewrite(fp); + with thisuser do begin + if (rname) then writeln(fp,allcaps(thisuser.realname)) else writeln(fp,allcaps(thisuser.name)); + if spd='300' then s:='1' else + if spd='1200' then s:='2' else + if spd='2400' then s:='0' else + if spd='9600' then s:='3' else + if spd='KB' then s:='5' else + s:='4'; + writeln(fp,s); + writeln(fp,allcaps(thisuser.citystate)); + writeln(fp,cstr(thisuser.sl)); + writeln(fp,timestr); + if okansi then writeln(fp,'COLOR') else writeln(fp,'MONO'); + writeln(fp,thisuser.pw); + writeln(fp,cstr(usernum)); + writeln(fp,'0'); + writeln(fp,copy(time,1,5)); + writeln(fp,copy(time,1,5)+' '+date); + writeln(fp,'A'); + writeln(fp,'0'); + writeln(fp,'999999'); + writeln(fp,'0'); + writeln(fp,'999999'); + writeln(fp,thisuser.ph); + writeln(fp,thisuser.laston+' 00:00'); + if (novice in thisuser.ac) then writeln(fp,'NOVICE') else writeln(fp,'EXPERT'); + writeln(fp,'All'); + writeln(fp,'01/01/80'); + writeln(fp,cstr(thisuser.loggedon)); + writeln(fp,cstr(thisuser.pagelen)); + writeln(fp,'0'); + writeln(fp,cstr(thisuser.uploads)); + writeln(fp,cstr(thisuser.downloads)); + writeln(fp,'8 { Databits }'); + if ((incom) or (outcom)) then writeln(fp,'REMOTE') else writeln(fp,'LOCAL'); + if ((incom) or (outcom)) then writeln(fp,'COM'+cstr(modemr.comport)) else writeln(fp,'COM0'); + writeln(fp,thisuser.bday); + if spd='KB' then writeln(fp,cstr(modemr.waitbaud)) else writeln(fp,spd); + if ((incom) or (outcom)) then writeln(fp,'TRUE') else writeln(fp,'FALSE'); + if (spdarq) then write(fp,'MNP/ARQ') else write(fp,'Normal'); + writeln(fp,' Connection'); + writeln(fp,'12/31/99 23:59'); + writeln(fp,'1'); + writeln(fp,'1'); + end; + close(fp); +end; + +procedure write_sfdoors_dat(rname:boolean); { Spitfire SFDOORS.DAT } +var fp:text; + s:astr; +begin + assign(fp,'SFDOORS.DAT'); + rewrite(fp); + writeln(fp,cstr(usernum)); + if (rname) then writeln(fp,allcaps(thisuser.realname)) else writeln(fp,allcaps(thisuser.name)); + writeln(fp,thisuser.pw); + if (rname) then begin + if (pos(' ',thisuser.realname)=0) then s:=thisuser.realname + else s:=copy(thisuser.realname,1,pos(' ',thisuser.realname)-1); + end else begin + if (pos(' ',thisuser.name)=0) then s:=thisuser.name + else s:=copy(thisuser.name,1,pos(' ',thisuser.name)-1); + end; + writeln(fp,s); + if (spd='KB') then writeln(fp,'0') else writeln(fp,cstr(modemr.comport)); + writeln(fp,timestr); + writeln(fp,'0'); { seconds since midnight } + writeln(fp,start_dir); + if okansi then writeln(fp,'TRUE') else writeln(fp,'FALSE'); + writeln(fp,cstr(thisuser.sl)); + writeln(fp,cstr(thisuser.uploads)); + writeln(fp,cstr(thisuser.downloads)); + writeln(fp,cstr(systat.timeallow[thisuser.sl])); + writeln(fp,'0'); { time on (seconds) } + writeln(fp,'0'); { extra time (seconds) } + writeln(fp,'FALSE'); + writeln(fp,'FALSE'); + writeln(fp,'FALSE'); + if (spd='KB') then writeln(fp,'0') else writeln(fp,spd); + close(fp); +end; + +procedure dodoorfunc(kind:char; cline:astr); +var doorstart,doorend,doortime:datetimerec; + s,cline2:astr; + retcode,savsl,savdsl:integer; + realname:boolean; +begin + realname:=FALSE; + if ((sqoutsp(cline)='') and (incom)) then begin + print('This command is inoperative!'); + if (cso) then print('(An MString of "" will shell to DOS LOCALLY!)'); + exit; + end; + + if ((realsl<>-1) and (realdsl<>-1)) then begin + savsl:=thisuser.sl; savdsl:=thisuser.dsl; + thisuser.sl:=realsl; thisuser.dsl:=realdsl; + saveuf; + end; + +(* sprint(#3#3+'[> '+#3#0+'Opening door on '+ + #3#5+date+' '+time+#3#0+' ... Please wait.');*) + cline2:=cline; + if copy(allcaps(cline2),1,2)='R;' then begin + realname:=TRUE; + cline2:=copy(cline2,3,length(cline2)-2); + end; + s:=process_door(cline2); + case kind of + 'C':begin + commandline('Outputting CHAIN.TXT (WWIV) ...'); + write_chain_txt; + end; + 'D':begin + commandline('Outputting DORINFO1.DEF (RBBS-PC) ...'); + write_dorinfo1_def(realname); + end; + 'G':begin + commandline('Outputting DOOR.SYS (GAP) ...'); + write_door_sys(realname); + end; + 'S':begin + commandline('Outputting SFDOORS.DAT (Spitfire) ...'); + write_sfdoors_dat(realname); + end; + 'W':begin + commandline('Outputting CALLINFO.BBS (Wildcat!) ...'); + write_callinfo_bbs(realname); + end; + end; + commandline('Now running "'+s+'"'); + sysoplog('>> '+date+' '+time+'- Door "'+s+'"'); + close(sysopf); + + getdatetime(doorstart); + shel1; shelldos(FALSE,s,retcode); shel2; + getdatetime(doorend); + timediff(doortime,doorstart,doorend); + + chdir(start_dir); + append(sysopf); + + if ((realsl<>-1) and (realdsl<>-1)) then begin + reset(uf); seek(uf,usernum); read(uf,thisuser); close(uf); + thisuser.sl:=savsl; thisuser.dsl:=savdsl; + end; + + com_flush_rx; + getdatetime(tim); + + sysoplog('>> '+date+' '+time+'- Returned (spent '+longtim(doortime)+')'); +end; + +end. diff --git a/edit2.txt b/edit2.txt new file mode 100644 index 0000000..06618fd --- /dev/null +++ b/edit2.txt @@ -0,0 +1,14 @@ + 'E':if ((mso) and (lastname<>'')) then + editmessage(cn) + else begin + loadmhead(cn,mheader); + if ((mheader.fromi.usernum=usernum) and + (allcaps(mheader.fromi.real)= + allcaps(thisuser.realname))) then + editmessage(cn) + else begin + nl; + print('You didn''t post this message!'); + nl; + end; + end; \ No newline at end of file diff --git a/editpro.txt b/editpro.txt new file mode 100644 index 0000000..31cc29a --- /dev/null +++ b/editpro.txt @@ -0,0 +1,44 @@ +procedure editmessage(i:integer); +var t:text; + f:file; + mheader:mheaderrec; + mixr:msgindexrec; + s:string; + brdsig,dfdt1,dfdt2,newmsgptr,totload:longint; +begin + loadmhead(i,mheader); + + assign(t,'tgtempx.msg'); rewrite(t); + totload:=0; + repeat + blockreadstr2(brdf,s); + inc(totload,length(s)+2); + writeln(t,s); + until (totload>=mheader.msglength); + close(t); + getftime(t,dfdt1); + + tedit(allcaps('tgtempx.msg')); + assign(f,'tgtempx.msg'); + getftime(f,dfdt2); + close(f); + + if (dfdt1<>dfdt2) then begin + assign(t,'tgtempx.msg'); + reset(t); + mheader.msglength:=0; + repeat + readln(t,s); + inc(mheader.msglength,length(s)+2); + until (eof(t)); + close(f); + newmsgptr:=filesize(brdf); + seek(brdf,newmsgptr); + outmessagetext('tgtempx.msg',mheader,TRUE); + ensureloaded(i); + mixr:=mintab[getmixnum(i)]; + mixr.hdrptr:=newmsgptr; + savemix(mixr,i); + ensureloaded(i); + end; +end; diff --git a/execbat.pas b/execbat.pas new file mode 100644 index 0000000..0438ade --- /dev/null +++ b/execbat.pas @@ -0,0 +1,151 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit execbat; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, + myio; + +var + wind:windowrec; + sx,sy:integer; + wascls,savtw:boolean; + savcurwind:integer; + +procedure execbatch(var ok:boolean; showit:boolean; + bfn,tfn,dir,batline:astr; oklevel:integer); +procedure pexecbatch(showit:boolean; bfn,tfn,dir,batline:astr; + var retlevel:integer); +procedure shel(s:astr); +procedure shel1; +procedure shel2; + +implementation + +procedure execbatch(var ok:boolean; { result } + showit:boolean; { show working on user side } + bfn:astr; { .BAT filename } + tfn:astr; { temporary testing file } + dir:astr; { directory takes place in } + batline:astr; { .BAT file line to execute } + oklevel:integer); { DOS errorlevel for success } +var bfp:text; + odir,todev:astr; + i,rcode:integer; +begin + todev:=' >nul'; + if ((showit) and (incom)) then + todev:=' >'+systat.remdevice+' <'+systat.remdevice + else + if (wantout) then todev:=''; {' >con';} + + getdir(0,odir); + dir:=fexpand(dir); + while copy(dir,length(dir),1)='\' do dir:=copy(dir,1,length(dir)-1); + assign(bfp,bfn); + rewrite(bfp); + writeln(bfp,'echo off'); + writeln(bfp,chr(exdrv(dir)+64)+':'); + writeln(bfp,'cd '+dir); + writeln(bfp,batline+todev); + writeln(bfp,':done'); + writeln(bfp,chr(exdrv(odir)+64)+':'); + writeln(bfp,'cd '+odir); + writeln(bfp,'exit'); + close(bfp); + + if (wantout) then begin + tc(15); textbackground(1); clreol; write(batline); clreol; + tc(7); textbackground(0); writeln; + end; +{ if (todev=' >con') then todev:='' else todev:=' >nul';} + + shelldos(FALSE,bfn+todev,rcode); + + chdir(odir); + {$I-} erase(bfp); {$I+} + if (oklevel<>-1) then ok:=(rcode=oklevel) else ok:=TRUE; +end; + +procedure pexecbatch(showit:boolean; { show working on user side } + bfn:astr; { .BAT filename } + tfn:astr; { UNUSED ----------- } + dir:astr; { directory takes place in } + batline:astr; { .BAT file line to execute } + var retlevel:integer); { DOS errorlevel returned } +var tfp,bfp:text; + odir,todev:astr; +begin + todev:=' >nul'; + if (showit) and (incom) then + todev:=' >'+systat.remdevice+' <'+systat.remdevice + else + if (wantout) then todev:=' >con'; + + getdir(0,odir); + dir:=fexpand(dir); + while copy(dir,length(dir),1)='\' do dir:=copy(dir,1,length(dir)-1); + assign(bfp,bfn); + rewrite(bfp); + writeln(bfp,'echo off'); + writeln(bfp,chr(exdrv(dir)+64)+':'); + writeln(bfp,'cd '+dir); + writeln(bfp,batline+todev); + writeln(bfp,':done'); + writeln(bfp,chr(exdrv(odir)+64)+':'); + writeln(bfp,'cd '+odir); + writeln(bfp,'exit'); + close(bfp); + + if (wantout) then begin + tc(15); textbackground(1); clreol; write(batline); clreol; + tc(7); textbackground(0); writeln; + end; + if (todev=' >con') then todev:='' else todev:=' >nul'; + + shelldos(FALSE,bfn+todev,retlevel); + + chdir(odir); + {$I-} erase(bfp); {$I+} +end; + +procedure shel(s:astr); +begin + wascls:=FALSE; + savcurwind:=systat.curwindow; + if (s<>'') then begin + wascls:=TRUE; + sx:=wherex; sy:=wherey; + setwindow(wind,1,1,80,25,7,0,0); + clrscr; + textbackground(1); tc(15); clreol; + write(s); + textbackground(0); tc(7); writeln; + end else + if (savcurwind<>0) then sclearwindow; +{ if (not systat.istopwindow) then sclearwindow;} +end; + +procedure shel1; +begin + shel(''); +end; + +procedure shel2; +begin + if (wascls) then begin + clrscr; + removewindow(wind); + gotoxy(sx,sy); + topscr; + end else + if (savcurwind<>0) then schangewindow(TRUE,savcurwind); +end; + +end. diff --git a/execswap.pas b/execswap.pas new file mode 100644 index 0000000..ea1b8c9 --- /dev/null +++ b/execswap.pas @@ -0,0 +1,184 @@ +{ +Copyright (c) 1988 TurboPower Software +May be used freely as long as due credit is given + +Version 1.1 - 3/15/89 + save and restore EMS page map +Version 1.2 - 3/29/89 + add more compiler directives (far calls off, boolean short-circuiting) + add UseEmsIfAvailable to disable EMS usage when desired +Version 1.3 - 5/02/89 + fix problem with exit chain when InitExecSwap/ShutdownExecSwap called + more than once in a program + flush swap file before execing +} + +{$A+,B-,D-,E+,F+,I-,L-,N-,O-,R-,S-,V-} + +unit ExecSwap; + {-Memory-efficient DOS EXEC call} +interface + +const + UseEmsIfAvailable : Boolean = True; {True to use EMS if available} + BytesSwapped : LongInt = 0; {Bytes to swap to EMS/disk} + EmsAllocated : Boolean = False; {True when EMS allocated for swap} + FileAllocated : Boolean = False; {True when file allocated for swap} + +function ExecWithSwap(Path, CmdLine : String) : Word; + {-DOS EXEC supporting swap to EMS or disk} + +function InitExecSwap(LastToSave : Pointer; SwapFileName : String) : Boolean; + {-Initialize for swapping, returning TRUE if successful} + +procedure ShutdownExecSwap; + {-Deallocate swap area} + +implementation + +var + EmsHandle : Word; {Handle of EMS allocation block} + FrameSeg : Word; {Segment of EMS page frame} + FileHandle : Word; {DOS handle of swap file} + SwapName : String[80]; {ASCIIZ name of swap file} + SaveExit : Pointer; {Exit chain pointer} + + {rcg11172000 stubs follow...} + (* + {$L EXECSWAP} + function ExecWithSwap(Path, CmdLine : String) : Word; external; + procedure FirstToSave; external; + function AllocateSwapFile : Boolean; external; + procedure DeallocateSwapFile; external; + + {$F+} {These routines could be interfaced for general use} + function EmsInstalled : Boolean; external; + function EmsPageFrame : Word; external; + function AllocateEmsPages(NumPages : Word) : Word; external; + procedure DeallocateEmsHandle(Handle : Word); external; + function DefaultDrive : Char; external; + function DiskFree(Drive : Byte) : LongInt; external; + *) + +procedure DeallocateEmsHandle(Handle : Word); +begin +end; + +function ExecWithSwap(Path, CmdLine : String) : Word; +begin + writeln('STUB: execswap.pas; ExecWithSwap()...'); + ExecWithSwap := 0; +end; + +procedure FirstToSave; +begin +end; + +function AllocateSwapFile : Boolean; +begin + AllocateSwapFile := false; +end; + +procedure DeallocateSwapFile; +begin +end; + +function EmsInstalled : Boolean; +begin + EmsInstalled := false; +end; + +function EmsPageFrame : Word; +begin + EmsPageFrame := 0; +end; + +function AllocateEmsPages(NumPages : Word) : Word; +begin + AllocateEmsPages := 0; +end; + +function DefaultDrive : Char; +begin + DefaultDrive := #103; { 'C' } +end; + +function DiskFree(Drive : Byte) : LongInt; +begin + DiskFree := 10000000; +end; + + + + procedure ExecSwapExit; + begin + ExitProc := SaveExit; + ShutdownExecSwap; + end; + {$F-} + + procedure ShutdownExecSwap; + begin + if EmsAllocated then begin + DeallocateEmsHandle(EmsHandle); + EmsAllocated := False; + end else if FileAllocated then begin + DeallocateSwapFile; + FileAllocated := False; + end; + end; + + function PtrDiff(H, L : Pointer) : LongInt; + type + OS = record O, S : Word; end; {Convenient typecast} + begin + PtrDiff := (LongInt(OS(H).S) shl 4+OS(H).O)- + (LongInt(OS(L).S) shl 4+OS(L).O); + end; + + function InitExecSwap(LastToSave : Pointer; + SwapFileName : String) : Boolean; + const + EmsPageSize = 16384; {Bytes in a standard EMS page} + var + PagesInEms : Word; {Pages needed in EMS} + BytesFree : LongInt; {Bytes free on swap file drive} + DriveChar : Char; {Drive letter for swap file} + begin + InitExecSwap := False; + + if EmsAllocated or FileAllocated then + Exit; + BytesSwapped := PtrDiff(LastToSave, @FirstToSave); + if BytesSwapped <= 0 then + Exit; + + if UseEmsIfAvailable and EmsInstalled then begin + PagesInEms := (BytesSwapped+EmsPageSize-1) div EmsPageSize; + EmsHandle := AllocateEmsPages(PagesInEms); + if EmsHandle <> $FFFF then begin + EmsAllocated := True; + FrameSeg := EmsPageFrame; + if FrameSeg <> 0 then begin + InitExecSwap := True; + Exit; + end; + end; + end; + if Length(SwapFileName) <> 0 then begin + SwapName := SwapFileName+#0; + if Pos(':', SwapFileName) = 2 then + DriveChar := Upcase(SwapFileName[1]) + else + DriveChar := DefaultDrive; + BytesFree := DiskFree(Byte(DriveChar)-$40); + FileAllocated := (BytesFree > BytesSwapped) and AllocateSwapFile; + if FileAllocated then + InitExecSwap := True; + end; + end; + +begin + SaveExit := ExitProc; + ExitProc := @ExecSwapExit; +end. diff --git a/fastchr.asm b/fastchr.asm new file mode 100644 index 0000000..e16eba4 --- /dev/null +++ b/fastchr.asm @@ -0,0 +1,240 @@ +;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +;+ + +;+ This asm file contains 2 pascal procedures for + +;+ linking with TTT version 5.0. The procedures are: + +;+ + +;+ scrolllistup; + +;+ scrolllistdown; + +;+ + +;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + +data segment byte public + extrn snowcheck:byte + extrn usebios:byte + extrn vidseg:word + extrn windmin,windmax:word + xpos db ? + ypos db ? +data ends + + +code segment byte public + + assume cs:code,ds:data + public fastchr + +;++++++++++++++++++++++++++++++++++++ +;+ C A L M E M P O I N T E R + +;++++++++++++++++++++++++++++++++++++ + +;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +;+ + +;+ CALCMEMPOINTER is a local procedure that is called by + +;+ Fastwrite, PlainWrite and Attribute. It places the segment + +;+ and offset of the first attribute, in ES:DI ready for an + +;+ LDS. Vseg and Vofs point to the first attribute of the + +;+ screen, the final location is computed by adding Row*160 + +;+ (80 attribs and 80 chars per row) and then adding 2*Col. + +;+ The passed Row and Column are decremented by one to fit + +;+ with DOS's 0..79, 0..24 coordinate system. + +;+ + +;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +calcmempointer proc near + + xor ax,ax ;AX=0 + mov cl,al ;CL=0 + mov bh,al ;BH=0 + shr cx,1 ;CX=Y*128 + mov di,cx ;store in DI + shr di,1 ;DI=y*64 + shr di,1 ;DI=y*32 + add di,cx ;DI=y*160 + shl bx,1 ;account for attribute bytes + add di,bx ;DI=(y*160)+(x*2) + mov es,vidseg ;ES:DI points to color attribute + ret + +calcmempointer endp + +;+++++++++++++++++++++++++++++++++++++++ +;+ F A S T C H R + +;+++++++++++++++++++++++++++++++++++++++ + +wattr equ byte ptr [bp+6] ;write attribute +wchr equ byte ptr [bp+8] ;write character + +fastchr proc far + + push bp ;Save BP + mov bp,sp ;Set up stack frame + + mov ax,40h + mov es,ax + mov bx,es:word ptr [0050h] ;X position [0040:0050] + mov cx,es:word ptr [0051h] ;Y position [0040:0051] + + mov xpos,bl + mov ypos,cl + + cmp usebios,1 ;check whether to use BIOS + je FCusebios1 + +FCdirectscr1: + mov ch,cl + mov cl,0 + mov bh,cl + call calcmempointer + mov bh,wattr ;attribute + mov bl,wchr ;character + + cmp snowcheck,1 ;check whether to check snow + jne FCdoch5 + push ax + mov dx,03DAh +FCdoch1: + cli ;interrupts OFF +FCdoch2: + in al,dx ;get 6845 status + test al,8 ;check for vertical retrace + jnz FCdoch4 ;in progress? go.. + rcr al,1 ;wait for end of horizontal + jc FCdoch2 ; retrace +FCdoch3: + in al,dx ;get 6845 status again + rcr al,1 ;wait for horizontal + jnc FCdoch3 ; retrace +FCdoch4: + mov ax,bx + stosw ;store video word into ES:DI + sti ;interrupts ON + jmp FCdoch6 ;ALL DONE! +FCdoch5: + mov ax,bx + stosw ;no waiting!!!!! +FCdoch6: + jmp FCmovecursor + +FCusebios1: +;assumes that cursor is already positioned to the correct place on the screen + mov ah,9 ;service=write attr & chr at cursor + mov al,wchr ;write character + mov bh,0 ;page 0 + mov bl,wattr ;write attribute + mov cx,1 ;write 1x + int 10h + +FCmovecursor: + mov ax,windmin + mov bx,windmax + + mov dl,xpos ;X pos in DL + mov dh,ypos ;Y pos in DH + + inc dl ;increment X + + cmp dl,bl ;is X>79 ?? + jg FCmc1 + jmp FCnoscroll +FCmc1: + mov dl,al ;X:=0 + inc dh ;increment Y + cmp dh,bh ;is Y>25 ?? + jg FCmc2 + jmp FCnoscroll +FCmc2: + +;scrolling stuff + + cmp usebios,1 ;check whether to use BIOS + jne FCdirectscr2 + jmp FCusebios2 + +FCdirectscr2: + push ds ;save DS ... + mov al,snowcheck ;grab before changing DS + push ax + + mov dx,windmax + mov cx,windmin + sub dh,ch ;difference in DH (Y) + mov dl,0 + shr dx,1 ;DX=Y*128 + shr dx,1 ;DX=Y*64 + mov cx,dx ;store in CX + shr cx,1 ;CX=Y*32 + shr cx,1 ;CX=Y*16 + add cx,dx ;CX=Y*80 + push cx + + mov cx,0 + mov bx,windmin ;BL=X position + mov ch,bh ;CH=Y position + mov bh,0 + inc ch ;2nd line of window + call calcmempointer + mov ds,vidseg + mov si,di ;DS:SI + + mov dx,ds + mov es,dx ;ES:DI + sub di,0A0h + + pop cx + + cld ;set direction to FORWARD + pop ax + cmp al,1 ;check whether to check snow + jne FCdscr5 + mov dx,03DAh +FCdscr1: + cli ;interrupts OFF +FCdscr2: + in al,dx ;get 6845 status + test al,8 ;check for vertical retrace + jnz FCdscr4 ;in progress? go.. + rcr al,1 ;wait for end of horizontal + jc FCdscr2 ; retrace +FCdscr3: + in al,dx ;get 6845 status again + rcr al,1 ;wait for horizontal + jnc FCdscr3 ; retrace +FCdscr4: + movsw ;move it out... + sti ;interrupts ON + loop FCdscr1 ;get next video word + jmp FCdscr6 ;ALL DONE! +FCdscr5: + rep movsw ;no waiting!!!!! +FCdscr6: + pop ds + mov cx,windmin + mov dx,windmax + mov dl,cl + jmp FCnoscroll + +FCusebios2: + mov cx,ax ;windmin + mov dx,bx ;windmax + mov ax,0601h ;func=scroll up, 1 line + mov bh,wattr + int 10h + + mov dl,cl ;X=windmin's X position (1) + +FCnoscroll: + mov ah,2 + mov bh,0 + int 10h + + mov sp,bp ;Restore SP + pop bp ;Restore BP + ret ;Remove parameters and return + +fastchr endp + +code ends + + end + diff --git a/file0.pas b/file0.pas new file mode 100644 index 0000000..dc5113a --- /dev/null +++ b/file0.pas @@ -0,0 +1,389 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file0; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + + myio, + common; + +const + ulffopen1:boolean=TRUE; { whether ulff has been opened before } + +var + dirinfo:searchrec; + found:boolean; + +function align(fn:astr):astr; +function baddlpath:boolean; +function badulpath:boolean; +function bslash(b:boolean; s:astr):astr; +function existdir(s:astr):boolean; +procedure ffile(fn:astr); +procedure fileinfo(f:ulfrec; editing:boolean; var abort,next:boolean); +procedure fiscan(var pl:integer); +function fit(f1,f2:astr):boolean; +procedure gfn(var fn:astr); +function isgifdesc(d:astr):boolean; +function isgifext(fn:astr):boolean; +function isul(s:astr):boolean; +function iswildcard(s:astr):boolean; +procedure nfile; +procedure nrecno(fn:astr; var pl,rn:integer); +procedure recno(fn:astr; var pl,rn:integer); +function rte:real; +procedure star(s:astr); +function stripname(i:astr):astr; +function tcheck(s:real; i:integer):boolean; +function tchk(s:real; i:real):boolean; +procedure verbfileinfo(pt:integer; editing,abort,next:boolean); + +implementation + +function align(fn:astr):astr; +var f,e,t:astr; c,c1:integer; +begin + c:=pos('.',fn); + if (c=0) then begin + f:=fn; e:=' '; + end else begin + f:=copy(fn,1,c-1); e:=copy(fn,c+1,3); + end; + f:=mln(f,8); + e:=mln(e,3); + c:=pos('*',f); if (c<>0) then for c1:=c to 8 do f[c1]:='?'; + c:=pos('*',e); if (c<>0) then for c1:=c to 3 do e[c1]:='?'; + c:=pos(' ',f); if (c<>0) then for c1:=c to 8 do f[c1]:=' '; + c:=pos(' ',e); if (c<>0) then for c1:=c to 3 do e[c1]:=' '; + align:=f+'.'+e; +end; + +function baddlpath:boolean; +var s:string; +begin + if (badfpath) then begin + nl; + sprint(#3#7+'File base #'+cstr(fileboard)+': Unable to perform command.'); + sprint(#3#5+'Bad DL file path: "'+memuboard.dlpath+'".'); + sprint(#3#5+'Please inform the SysOp.'); + sysoplog('Invalid DL path (file base #'+cstr(fileboard)+'): "'+ + memuboard.dlpath+'"'); + end; + baddlpath:=badfpath; +end; + +function badulpath:boolean; +var s:string; +begin + if (badufpath) then begin + nl; + sprint(#3#7+'File base #'+cstr(fileboard)+': Unable to perform command.'); + sprint(#3#5+'Bad UL file path: "'+memuboard.ulpath+'".'); + sprint(#3#5+'Please inform the SysOp.'); + sysoplog('Invalid UL path (file base #'+cstr(fileboard)+'): "'+ + memuboard.ulpath+'"'); + end; + badulpath:=badufpath; +end; + +function bslash(b:boolean; s:astr):astr; +begin + if (b) then begin + while (copy(s,length(s)-1,2)='\\') do s:=copy(s,1,length(s)-2); + if (copy(s,length(s),1)<>'\') then s:=s+'\'; + end else + while (copy(s,length(s),1)='\') do s:=copy(s,1,length(s)-1); + bslash:=s; +end; + +function existdir(s:astr):boolean; +var savedir:astr; + okd:boolean; +begin + okd:=TRUE; + s:=bslash(FALSE,fexpand(s)); + + if ((length(s)=2) and (copy(s,2,1)=':')) then begin + getdir(0,savedir); + {$I-} chdir(s); {$I+} + if (ioresult<>0) then okd:=FALSE; + chdir(savedir); + exit; + end; + + okd:=(exist(s)); + + if (okd) then begin + findfirst(s,anyfile,dirinfo); + if (dirinfo.attr and directory<>directory) or + (doserror<>0) then okd:=FALSE; + end; + + existdir:=okd; +end; + +procedure fiscan(var pl:integer); { loads in memuboard ... } +var f:ulfrec; + dirinfo:searchrec; + s:astr; +begin + s:=memuboard.dlpath; s:=copy(s,1,length(s)-1); + if ((length(s)=2) and (s[2]=':')) then badfpath:=FALSE + else begin + findfirst(s,dos.directory,dirinfo); + badfpath:=(doserror<>0); + end; + + s:=memuboard.ulpath; s:=copy(s,1,length(s)-1); + if ((length(s)=2) and (s[2]=':')) then badufpath:=FALSE + else begin + findfirst(s,dos.directory,dirinfo); + badufpath:=(doserror<>0); + end; + + if (not ulffopen1) then + if (filerec(ulff).mode<>fmclosed) then close(ulff) + else + begin + end + else + ulffopen1:=FALSE; + loaduboard(fileboard); + if (fbdirdlpath in memuboard.fbstat) then + assign(ulff,memuboard.dlpath+memuboard.filename+'.DIR') + else + assign(ulff,systat.gfilepath+memuboard.filename+'.DIR'); + {$I-} reset(ulff); {$I+} + if (ioresult<>0) then begin + rewrite(ulff); + f.blocks:=0; + write(ulff,f); + end; + seek(ulff,0); read(ulff,f); + pl:=f.blocks; + bnp:=FALSE; +end; + +procedure ffile(fn:astr); +begin + findfirst(fn,anyfile,dirinfo); + found:=(doserror=0); +end; + +procedure fileinfo(f:ulfrec; editing:boolean; var abort,next:boolean); +var dt:datetimerec; + s:astr; + r:real; + x:longint; + i,j:integer; + u:userrec; +begin + j:=0; + with f do + for i:=1 to 8 do begin + if (i=4) and (editing) then inc(i); + inc(j); + if (editing) then s:=#3#3+cstr(j)+'. ' else s:=#3#1; + case i of + 1:s:=s+'Filename : '+#3#3+'"'+filename+'"'; + 2:s:=s+'Description: '+#3#3+description; + 3:begin + x:=blocks; x:=x*128; + s:=s+'File size : '+#3#5+cstrl(x)+' bytes ('+cstr((blocks+7) div 8)+'K) / '+cstr(blocks)+' blocks'; + end; + 4:begin + r:=rte*blocks; r2dt(r,dt); + s:=s+'Aprox. time: '+#3#5+longtim(dt); + end; + 5:if (editing) or (aacs(memuboard.nameacs)) then + s:=s+'UL''d by : '+#3#9+caps(stowner)+' #'+cstr(owner); + 6:s:=s+'UL''d on : '+#3#9+date; + 7:s:=s+'Times DL''d : '+#3#9+cstr(nacc); + 8:begin + s:=s+'File points: '+#3#4+cstr(filepoints); + if (notval in filestat) then s:=s+' '+#3#8+''; + if (isrequest in filestat) then s:=s+' '+#3#9+'Ask (Request File)'; + if (resumelater in filestat) then s:=s+' '+#3#7+'Resume later'; + end; + end; + if (s<>#3#1) then printacr(s,abort,next); + end; + if (f.vpointer<>-1) then verbfileinfo(f.vpointer,editing,abort,next); +end; + +function fit(f1,f2:astr):boolean; +var tf:boolean; c:integer; +begin + tf:=TRUE; + for c:=1 to 12 do + if (f1[c]<>f2[c]) and (f1[c]<>'?') then tf:=FALSE; + fit:=tf; +end; + +procedure gfn(var fn:astr); +begin + sprint(fstring.gfnline1); + prt(fstring.gfnline2); input(fn,12); + if (pos('.',fn)=0) then fn:=fn+'*.*'; + fn:=align(fn); +end; + +function isgifdesc(d:astr):boolean; +begin + isgifdesc:=((copy(d,1,1)='(') and (pos('x',d) in [1..7]) and + (pos('c)',d)<>0)); +end; + +function isgifext(fn:astr):boolean; +begin + fn:=align(stripname(sqoutsp(fn))); + fn:=allcaps(copy(fn,length(fn)-2,3)); + isgifext:=((fn='GIF') or (fn='GYF')); +end; + +function isul(s:astr):boolean; +begin + isul:=((pos('\',s)<>0) or (pos(':',s)<>0) or (pos('|',s)<>0)); +end; + +function iswildcard(s:astr):boolean; +begin + iswildcard:=((pos('*',s)<>0) or (pos('?',s)<>0)); +end; + +procedure nfile; +begin + findnext(dirinfo); + found:=(doserror=0); +end; + +procedure nrecno(fn:astr; var pl,rn:integer); +var c:integer; + f:ulfrec; +begin + rn:=0; + if (lrn=0) then begin + c:=lrn+1; + while (c<=pl) and (rn=0) do begin + seek(ulff,c); read(ulff,f); + if pos('.',f.filename)<>9 then begin + f.filename:=align(f.filename); + seek(ulff,c); write(ulff,f); + end; + if fit(lfn,f.filename) then rn:=c; + inc(c); + end; + lrn:=rn; + end; +end; + +procedure recno(fn:astr; var pl,rn:integer); +var f:ulfrec; + c:integer; +begin + fn:=align(fn); + fiscan(pl); + rn:=0; c:=1; + while (c<=pl) and (rn=0) do begin + seek(ulff,c); read(ulff,f); + if pos('.',f.filename)<>9 then begin + f.filename:=align(f.filename); + seek(ulff,c); write(ulff,f); + end; + if fit(fn,f.filename) then rn:=c; + inc(c); + end; + lrn:=rn; + lfn:=fn; +end; + +function rte:real; +var i:integer; +begin + i:=value(spd); if (i=0) then i:=modemr.waitbaud; + rte:=1400.0/i; +end; + +procedure star(s:astr); +begin + cl(4); if (okansi) then prompt('þ ') else prompt('* '); + cl(3); if (s<>#1) then sprint(s); +end; + +function stripname(i:astr):astr; +var i1:astr; + n:integer; + + function nextn:integer; + var n:integer; + begin + n:=pos(':',i1); + if (n=0) then n:=pos('\',i1); + if (n=0) then n:=pos('/',i1); + nextn:=n; + end; + +begin + i1:=i; + while (nextn<>0) do i1:=copy(i1,nextn+1,80); + stripname:=i1; +end; + +function tcheck(s:real; i:integer):boolean; +var r:real; +begin + r:=timer-s; + if r<0.0 then r:=r+86400.0; + if (r<0.0) or (r>32760.0) then r:=32766.0; + if trunc(r)>i then tcheck:=FALSE else tcheck:=TRUE; +end; + +function tchk(s:real; i:real):boolean; +var r:real; +begin + r:=timer; + if ri then tchk:=FALSE else tchk:=TRUE; +end; + +procedure verbfileinfo(pt:integer; editing,abort,next:boolean); +var v:verbrec; + i:integer; + s:astr; + vfo:boolean; +begin + v.descr[1]:=''; + if pt<>-1 then begin + vfo:=(filerec(verbf).mode<>fmclosed); + {$I-} if not vfo then reset(verbf); {$I+} + if ioresult=0 then begin + {$I-} seek(verbf,pt); read(verbf,v); {$I+} + if ioresult=0 then + with v do + for i:=1 to 4 do + if descr[i]='' then i:=4 + else begin + s:=#3#5; + if (editing) then s:=s+' '; + if (i=1) then s:=s+'Verbose : ' else s:=s+' : '; + s:=s+#3#4+descr[i]; + if (editing) and (i=1) then s:=s+#3#2+' ('+cstr(pt)+')'; + printacr(s,abort,next); + end; + if (not vfo) then close(verbf); + end; + end; + if (editing) then + if (pt=-1) then printacr(#3#5' No Verbose',abort,next) + else + if (v.descr[1]='') then + printacr(#3#7' No Verbose YET'+#3#2+' ('+cstr(pt)+')',abort,next); +end; + +end. diff --git a/file1.pas b/file1.pas new file mode 100644 index 0000000..4dbb2a2 --- /dev/null +++ b/file1.pas @@ -0,0 +1,1035 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file1; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, common; + +procedure dodl(fpneed:integer); +procedure doul(pts:integer); +procedure showuserfileinfo; +function okdl(f:ulfrec):boolean; +procedure dlx(f1:ulfrec; rn:integer; var abort:boolean); +procedure dl(fn:astr); +procedure dodescrs(var f:ulfrec; var v:verbrec; var pl:integer; var tosysop:boolean); +procedure writefv(rn:integer; f:ulfrec; v:verbrec); +procedure newff(f:ulfrec; v:verbrec); +procedure doffstuff(var f:ulfrec; fn:astr; var gotpts:integer); +procedure arcstuff(var ok,convt:boolean; var blks:integer; var convtime:real; + itest:boolean; fpath:astr; var fn,descr:astr); +procedure idl; +procedure iul; + +procedure fbaselist; +procedure unlisted_download(s:astr); +procedure do_unlisted_download; +function nfvpointer:longint; + +implementation + +uses + file0, file4, file8, file14, + mail2, + archive1; + +var + locbatup:boolean; + +procedure dodl(fpneed:integer); +begin + nl; + nl; + if (not aacs(systat.nofilepts)) or + (not (fnofilepts in thisuser.ac)) then begin + if (fpneed>0) then dec(thisuser.filepoints,fpneed); + if (thisuser.filepoints<0) then thisuser.filepoints:=0; + sprint(#3#5+'Enjoy the file, '+thisuser.name+'!'); + if (fpneed<>0) then + sprint(#3#5+'Your file points have been deducted to '+cstr(thisuser.filepoints)+'.'); + end; +end; + +procedure doul(pts:integer); +begin + if (not aacs(systat.ulvalreq)) then begin + sprint(#3#5+'Thanks for the upload, '+thisuser.name+'!'); + if (systat.uldlratio) then + sprint(#3#5+'You will receive file credit as soon as the SysOp validates the file!') + else + sprint(#3#5+'You will receive file points as soon as the SysOp validates the file!'); + end else + if ((not systat.uldlratio) and (not systat.fileptratio) and (pts=0)) then begin + sprint(#3#5+'Thanks for the upload, '+thisuser.name+'!'); + sprint(#3#5+'You will receive file points as soon as the Sysop validates the file!'); + end else + inc(thisuser.filepoints,pts); +end; + +procedure showuserfileinfo; +begin + with thisuser do + commandline('U/L: '+cstr(uploads)+'/'+cstr(trunc(uk))+ + 'k ³ D/L: '+cstr(downloads)+'/'+cstr(trunc(dk))+'k'); +end; + +function okdl(f:ulfrec):boolean; +var s:astr; + b:boolean; + + procedure nope(s:astr); + begin + if (b) then sprint(s); + b:=FALSE; + end; + +begin + b:=TRUE; + if (isrequest in f.filestat) then begin + printf('reqfile'); + if (nofile) then begin + nl; + sprint(#3#5+'You must Request this file -- Ask '+ + systat.sysopname+' for it.'); + nl; + end; + dyny:=TRUE; + if (pynq('Request this file now? [Y] : ')) then begin + s:=sqoutsp(f.filename); + irt:='File Request of "'+s+'" from file base #'+cstr(ccuboards[1][fileboard]); + imail(1); + end; + b:=FALSE; + end; + if ((resumelater in f.filestat) and (not fso)) then + nope('You can''t do anything with RESUME-LATER files.'); + if ((notval in f.filestat) and (not aacs(systat.dlunval))) then + nope('You can''t do anything with UNVALIDATED files.'); + if (thisuser.filepoints0) and + (not aacs(systat.nofilepts)) and + (not (fnofilepts in thisuser.ac)) and + (not (fbnoratio in memuboard.fbstat)) then + nope(fstring.nofilepts); + if (nsl'; + star(s); + + s:=#3#3+'Download "'+sqoutsp(f1.filename)+'" from '+memuboard.name; + + tooktime1:=dt2r(tooktime); + if (tooktime1>=1.0) then begin + cps:=f1.blocks; cps:=cps*128; + cps:=trunc(cps/tooktime1); + end else + cps:=0; + + s:=s+#3#3+' ('+cstr(f1.blocks div 8)+'k, '+ctim(dt2r(tooktime))+ + ', '+cstr(cps)+' cps)'; + sysoplog(s); + if (not (fbnoratio in memuboard.fbstat)) and + (f1.filepoints>0) then dodl(f1.filepoints); + showuserfileinfo; + + if (rn<>-1) then begin + inc(f1.nacc); + seek(ulff,rn); write(ulff,f1); + end; + end; + end; + if (ps) then begin + nl; + sprompt(#3#5+'Continue with or [Q]uit :'+#3#3); + onek(c,'Q '^M); + abort:=(c='Q'); + end; +end; + +procedure dl(fn:astr); +var pl,rn:integer; + f:ulfrec; + abort:boolean; +begin + abort:=FALSE; + recno(fn,pl,rn); + if (baddlpath) then exit; + if (rn=0) then print('File not found.') + else + while (rn<>0) and (not abort) and (not hangup) do begin + reset(ulff); + seek(ulff,rn); read(ulff,f); + nl; + dlx(f,rn,abort); + nrecno(fn,pl,rn); + end; + reset(uf); close(uf); + close(ulff); +end; + +procedure idl; +var s:astr; down:boolean; +begin + down:=TRUE; + if (not intime(timer,systat.dllowtime,systat.dlhitime)) then down:=FALSE; + if (spd='300') then + if (not intime(timer,systat.b300dllowtime,systat.b300dlhitime)) then + down:=FALSE; + if (not down) then printf('dlhours') + else begin + nl; + sprint(fstring.downloadline); + nl; + prt('Filename: '); mpl(12); input(s,12); + if (s<>'') then dl(s); + end; +end; + +procedure dodescrs(var f:ulfrec; {* file record *} + var v:verbrec; {* verbose description record *} + var pl:integer; {* # files in dir *} + var tosysop:boolean); {* whether to-SysOp *} +var i,maxlen:integer; + isgif:boolean; +begin + if ((tosysop) and (systat.tosysopdir<>255) and + (systat.tosysopdir>=0) and (systat.tosysopdir<=maxulb)) then begin + nl; + print('Enter a single "\" in front of the description if it'); + print('is for the SysOp ONLY.'); + end else + tosysop:=FALSE; + nl; + + loaduboard(fileboard); + isgif:=isgifext(f.filename); + maxlen:=54; + if ((fbusegifspecs in memuboard.fbstat) and (isgif)) then dec(maxlen,14); + + print('Please enter a one line description ('+cstr(maxlen)+' chrs max)'); + repeat + prt(':'); + mpl(maxlen); inputl(f.description,maxlen); + if (((f.description[1]='\') or (rvalidate in thisuser.ac)) + and (tosysop)) then begin + fileboard:=systat.tosysopdir; + close(ulff); + fiscan(pl); + tosysop:=TRUE; + end else + tosysop:=FALSE; + if (f.description[1]='\') then f.description:=copy(f.description,2,80); + nl; + until ((f.description<>'') or (fso) or (hangup)); + v.descr[1]:=''; + dyny:=FALSE; + if (pynq('Leave a verbose description? ')) then begin + nl; + print('You may use up to four lines of 50 characters each.'); + print('Enter a blank line to end.'); + nl; + i:=1; + repeat + prt(cstr(i)+':'); + mpl(50); + inputl(v.descr[i],50); + if (v.descr[i]='') then i:=4; + inc(i); + until ((i=5) or (hangup)); + if (v.descr[1]<>'') then f.vpointer:=nfvpointer + else begin + nl; sprint(#3#7+'No verbose description saved.'); + end; + end; + if (v.descr[1]='') then f.vpointer:=-1; +end; + +procedure writefv(rn:integer; f:ulfrec; v:verbrec); +var vfo:boolean; +begin + seek(ulff,rn); + write(ulff,f); + + if (v.descr[1]<>#1#1#0#1#1) and (f.vpointer<>-1) then begin + vfo:=(filerec(verbf).mode<>fmclosed); + if (not vfo) then reset(verbf); + seek(verbf,f.vpointer); write(verbf,v); + if (not vfo) then close(verbf); + end; +end; + +procedure newff(f:ulfrec; v:verbrec); {* ulff needs to be open before calling *} +var i,pl:integer; + fo:boolean; + f1:ulfrec; +begin + seek(ulff,0); read(ulff,f1); pl:=f1.blocks; + + for i:=pl downto 1 do begin + seek(ulff,i); read(ulff,f1); + seek(ulff,i+1); write(ulff,f1); + end; + writefv(1,f,v); + + inc(pl); f1.blocks:=pl; + seek(ulff,0); write(ulff,f1); +end; + +procedure doffstuff(var f:ulfrec; fn:astr; var gotpts:integer); +var rfpts:real; +begin + f.filename:=align(fn); + f.owner:=usernum; + f.stowner:=allcaps(thisuser.name); + f.date:=date; + f.daten:=daynum(date); + f.nacc:=0; + + if (not systat.fileptratio) then begin + f.filepoints:=0; + gotpts:=0; + end else begin + rfpts:=(f.blocks/8)/systat.fileptcompbasesize; + f.filepoints:=round(rfpts); + gotpts:=round(rfpts*systat.fileptcomp); + if (gotpts<1) then gotpts:=1; + end; + + f.filestat:=[]; + if (not fso) and (not systat.validateallfiles) then + f.filestat:=f.filestat+[notval]; + f.ft:=255; {* ft; *} +end; + +procedure arcstuff(var ok,convt:boolean; { if ok - if converted } + var blks:integer; { # blocks } + var convtime:real; { convert time } + itest:boolean; { whether to test integrity } + fpath:astr; { filepath } + var fn:astr; { filename } + var descr:astr); { description } +var fi:file of byte; + convtook,convstart,convend:datetimerec; + oldnam,newnam,s,sig:astr; + sttime:real; + x,y,c:word; + oldarc,newarc:integer; +begin + {* oldarc: current archive format, 0 if none + * newarc: desired archive format, 0 if none + * oldnam: current filename + * newnam: desired archive format filename + *} + + convtime:=0.0; + ok:=TRUE; + + assign(fi,fpath+fn); + {$I-} reset(fi); {$I+} + if (ioresult<>0) then blks:=0 + else begin + blks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + end; + + newarc:=memuboard.arctype; + oldarc:=1; + oldnam:=sqoutsp(fpath+fn); + while (systat.filearcinfo[oldarc].ext<>'') and + (systat.filearcinfo[oldarc].ext<>copy(fn,length(fn)-2,3)) and + (oldarc0) and (newarc<>0)) then begin + {* archive extension supported *} + newnam:=fn; + if (pos('.',newnam)<>0) then newnam:=copy(newnam,1,pos('.',newnam)-1); + newnam:=sqoutsp(fpath+newnam+'.'+systat.filearcinfo[newarc].ext); + {* if integrity tests supported ... *} + if ((itest) and (systat.filearcinfo[oldarc].testline<>'')) then begin + star('Testing file integrity ...'); + arcintegritytest(ok,oldarc,oldnam); + if (not ok) then begin + sysoplog(#3#8'>>>>'#3#5+' "'+oldnam+'" on #'+cstr(fileboard)+ + ': Errors in integrity test'); + star('Errors in integrity test! File not passed.'); + end else + star('No errors in testing, file passed.'); + end; + + {* if conversion required ... *} + if ((ok) and (oldarc<>newarc) and (newarc<>0)) then begin + convt:=incom; {* don't convert if local and non-file-SysOp *} + s:=systat.filearcinfo[newarc].ext; + if (fso) then begin + dyny:=TRUE; + convt:=pynq('Convert archive to .'+s+' format? [Yes] : '); + end; + if (convt) then begin + nl; + + getdatetime(convstart); + conva(ok,oldarc,newarc,'tgtemp5.$$$',oldnam,newnam); + getdatetime(convend); + timediff(convtook,convstart,convend); + convtime:=dt2r(convtook); + + if (ok) then begin + assign(fi,fpath+fn); + rewrite(fi); close(fi); erase(fi); + assign(fi,newnam); + {$I-} reset(fi); {$I+} + if (ioresult<>0) then ok:=FALSE + else begin + blks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + if (blks=0) then ok:=FALSE; + end; + fn:=align(stripname(newnam)); + star('No errors in conversion, file passed.'); + end else begin + assign(fi,newnam); + rewrite(fi); close(fi); erase(fi); + sysoplog(#3#8+'>>>>'#3#5+' "'+oldnam+'" on #'+ + cstr(fileboard)+': Conversion unsuccessful'); + star('Errors in conversion! Original format retained.'); + newarc:=oldarc; + end; + ok:=TRUE; + end else + newarc:=oldarc; + end; + + {* if comment fields supported/desired ... *} + if (ok) and (systat.filearcinfo[newarc].cmtline<>'') then begin + s:=sqoutsp(fpath+fn); + arccomment(ok,newarc,memuboard.cmttype,s); + ok:=TRUE; + end; + end; + fn:=sqoutsp(fn); + + if ((isgifext(fn)) and (fbusegifspecs in memuboard.fbstat)) then begin + getgifspecs(memuboard.dlpath+fn,sig,x,y,c); + s:='('+cstrl(x)+'x'+cstrl(y)+','+cstr(c)+'c) '; + descr:=s+descr; + if (length(descr)>60) then descr:=copy(descr,1,60); + end; +end; + +function searchfordups(completefn:astr):boolean; +var wildfn,nearfn,s:astr; + i:integer; + fcompleteacc,fcompletenoacc,fnearacc,fnearnoacc, + hadacc,b1,b2:boolean; + + procedure searchb(b:integer; fn:astr; var hadacc,fcl,fnr:boolean); + var f:ulfrec; + oldboard,pl,rn:integer; + begin + oldboard:=fileboard; + hadacc:=fbaseac(b); { loads in memuboard } + fileboard:=b; + + recno(fn,pl,rn); + if (badfpath) then exit; + while (rn<=pl) and (rn<>0) do begin + seek(ulff,rn); read(ulff,f); + if (align(f.filename)=align(completefn)) then fcl:=TRUE + else begin + nearfn:=align(f.filename); + fnr:=TRUE; + end; + nrecno(fn,pl,rn); + end; + close(ulff); + fileboard:=oldboard; + fiscan(pl); + end; + +begin + nl; + sprompt(#3#5+'Searching for duplicate files ... '); + + searchfordups:=TRUE; + + wildfn:=copy(align(completefn),1,9)+'???'; + fcompleteacc:=FALSE; fcompletenoacc:=FALSE; + fnearacc:=FALSE; fnearnoacc:=FALSE; + b1:=FALSE; b2:=FALSE; + + i:=0; + while (i<=maxulb) do begin + searchb(i,wildfn,hadacc,b1,b2); { fbaseac loads in memuboard ... } + loaduboard(i); + if (b1) then begin + s:='User tried upload "'+sqoutsp(completefn)+'" to #'+cstr(fileboard)+ + '; existed in #'+cstr(i); + if (not hadacc) then s:=s+' - no access to'; + sysoplog(s); + nl; nl; + if (hadacc) then + sprint(#3#5+'File "'+sqoutsp(completefn)+'" already exists in "'+ + memuboard.name+#3#5+' #'+cstr(i)+'".') + else + sprint(#3#5+'File "'+sqoutsp(completefn)+ + '" cannot be accepted by the system at this time.'); + sprint(#3#7+'Illegal filename.'); + exit; + end; + if (b2) then begin + s:='User entered upload filename "'+sqoutsp(completefn)+'" in #'+ + cstr(fileboard)+'; was warned that "'+sqoutsp(nearfn)+ + '" existed in #'+cstr(i)+'.'; + if (not hadacc) then s:=s+' - no access to'; + sysoplog(s); + nl; nl; + if (hadacc) then + sprint(#3#5+'Warning: file "'+sqoutsp(nearfn)+'" exists in "'+ + memuboard.name+#3#5+' #'+cstr(i)+'".') + else + sprint(#3#5+'Warning: file "'+sqoutsp(nearfn)+ + '" exists in a private SysOp directory.'); + searchfordups:=not pynq('Upload anyway? [No] : '); + exit; + end; + inc(i); + end; + + sprint('none found.'); nl; + searchfordups:=FALSE; +end; + +procedure ul(var abort:boolean; fn:astr; var addbatch:boolean); +var baf:text; + fi:file of byte; + f,f1:ulfrec; + wind:windowrec; + v:verbrec; + s:astr; + xferstart,xferend,tooktime,ulrefundgot1,convtime1:datetimerec; + ulrefundgot,convtime,rfpts,tooktime1:real; + cps,lng,origblocks:longint; + x,rn,pl,cc,oldboard,np,sx,sy,gotpts:integer; + c:char; + uls,ok,kabort,convt,aexists,resumefile,wenttosysop,offline:boolean; +begin + oldboard:=fileboard; + fiscan(pl); + if (badulpath) then exit; + + uls:=incom; ok:=TRUE; fn:=align(fn); rn:=0; + if (fn[1]=' ') or (fn[10]=' ') then ok:=FALSE; + for x:=1 to length(fn) do + ok:=(pos(fn[x],'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ. -@#$%^&()_')<>0); + np:=0; + for x:=1 to length(fn) do if (fn[x]='.') then inc(np); + if (np<>1) then ok:=FALSE; + if (not ok) then begin + print('Illegal filename.'); + exit; + end; + + {* aexists: if file already EXISTS in dir + rn: rec-num of file if already EXISTS in file listing + resumefile: if user is going to RESUME THE UPLOAD + uls: whether file is to be actually UPLOADED + offline: if uploaded a file to be offline automatically.. + *} + + resumefile:=FALSE; uls:=TRUE; offline:=FALSE; abort:=FALSE; + aexists:=exist(memuboard.ulpath+fn); + + recno(fn,pl,rn); + if (badulpath) then exit; + nl; + if (rn<>0) then begin + seek(ulff,rn); read(ulff,f); + resumefile:=(resumelater in f.filestat); + if (resumefile) then begin + print('This is a resume-later file.'); + resumefile:=((f.owner=usernum) or (fso)); + if (resumefile) then begin + if (not incom) then begin + print('Cannot be resumed locally.'); + exit; + end; + dyny:=TRUE; + resumefile:=pynq('Resume upload of "'+sqoutsp(fn)+'" ? '); + if (not resumefile) then exit; + end else begin + print(#3#7+'You are not the uploader of this file.'); + exit; + end; + end; + end; + if ((not aexists) and (not incom)) then begin + uls:=FALSE; + offline:=TRUE; + print('This file does not exist in the files directory.'); + if not pynq('Do you want to create an Offline file entry? ') then exit; + end; + if (not resumefile) then begin + if (((aexists) or (rn<>0)) and (not fso)) then begin + print('File already exists.'); + exit; + end; + if (pl>=memuboard.maxfiles) then begin + star('This directory is full.'); + exit; + end; + if (not aexists) and (not offline) and + (freek(exdrv(memuboard.ulpath))<=systat.minspaceforupload) + then begin + nl; star('Insufficient disk space.'); + c:=chr(exdrv(memuboard.ulpath)+64); + if c='@' then + sysoplog(#3#8+'>>>>'+#3#3+' Main BBS drive full! Insufficient space to upload a file!') + else sysoplog(#3#8+'>>>>'+#3#3+' '+c+': drive full! Insufficient space to upload a file!'); + exit; + end; + if (aexists) then begin + uls:=FALSE; + print('Am using "'+sqoutsp(memuboard.ulpath+fn)+'"'); + if (rn<>0) then sprint(#3#5+'NOTE: File already exists in listing!'); + dyny:=(rn=0); + if (locbatup) then begin + sprompt(#3#7+'[Q]uit or Upload this? (Y/N) ['+ + syn(dyny)+'] : '+#3#3); + onekcr:=FALSE; onekda:=FALSE; + onek(c,'QYN'^M); + if (rn<>0) then ok:=(c='Y') else ok:=(c in ['Y',^M]); + abort:=(c='Q'); + if (abort) then print('Quit') else + if (not ok) then print('No') else print('Yes'); + end else + ok:=pynq('Upload this? (Y/N) ['+syn(dyny)+'] : '); + rn:=0; + end; + + if ((systat.searchdup) and (ok) and (not abort) and (incom)) then + if (searchfordups(fn)) then exit; + + if (uls) then begin + dyny:=TRUE; + ok:=pynq('Upload "'+sqoutsp(fn)+'" ? '); + end; + if ((ok) and (uls) and (not resumefile)) then begin + assign(fi,memuboard.ulpath+fn); + {$I-} rewrite(fi); {$I+} + if ioresult<>0 then begin + {$I-} close(fi); {$I+} + cc:=ioresult; + ok:=FALSE; + end else begin + close(fi); + erase(fi); + end; + if (not ok) then begin + print('Unable to upload that filename.'); + exit; + end; + end; + end; + + if (not ok) then exit; + wenttosysop:=TRUE; + if (not resumefile) then begin + f.filename:=align(fn); + dodescrs(f,v,pl,wenttosysop); + end; + ok:=TRUE; + if (uls) then begin + showuserfileinfo; + + getdatetime(xferstart); + receive1(memuboard.ulpath+fn,resumefile,ok,kabort,addbatch); + + if (addbatch) then begin + inc(numubatchfiles); + ubatch[numubatchfiles].fn:=sqoutsp(fn); + with ubatch[numubatchfiles] do begin + section:=fileboard; + description:=f.description; + if (v.descr[1]<>'') then begin + inc(hiubatchv); + new(ubatchv[hiubatchv]); {* define dynamic memory *} + ubatchv[hiubatchv]^:=v; + vr:=hiubatchv; + end else + vr:=0; + end; + nl; + if (numubatchfiles<>1) then s:='s' else s:=''; + s:=cstr(numubatchfiles)+' file'+s+' now in upload batch queue.'; + star(s); + star('Hit alone to stop adding to queue.'); + nl; + fileboard:=oldboard; + exit; + end else begin + getdatetime(xferend); + timediff(tooktime,xferstart,xferend); + end; + + if (kabort) then begin + fileboard:=oldboard; + exit; + end; + + ulrefundgot:=(dt2r(tooktime))*(systat.ulrefund/100.0); + freetime:=freetime+ulrefundgot; + star('Gave time refund of '+ctim(ulrefundgot)); + + showuserfileinfo; + + if (not kabort) then star('Transfer complete.'); + nl; + end; + nl; + + convt:=FALSE; + if (not offline) then begin + assign(fi,memuboard.ulpath+fn); + {$I-} reset(fi); {$I+} + if (ioresult<>0) then ok:=FALSE + else begin + f.blocks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + if (f.blocks=0) then ok:=FALSE; + origblocks:=f.blocks; + end; + end; + + if ((ok) and (not offline)) then begin + arcstuff(ok,convt,f.blocks,convtime,uls,memuboard.ulpath,fn,f.description); + doffstuff(f,fn,gotpts); + + if (ok) then begin + if ((not resumefile) or (rn=0)) then newff(f,v) else writefv(rn,f,v); + + if (uls) then begin + if (aacs(systat.ulvalreq)) then begin + inc(thisuser.uploads); + inc(thisuser.uk,f.blocks div 8); + end; + inc(systat.todayzlog.uploads); + inc(systat.todayzlog.uk,f.blocks div 8); + end; + + s:=#3#3+'Upload "'+sqoutsp(fn)+'" on '+memuboard.name; + if (uls) then begin + tooktime1:=dt2r(tooktime); + if (tooktime1>=1.0) then begin + cps:=f.blocks; cps:=cps*128; + cps:=trunc(cps/tooktime1); + end else + cps:=0; + s:=s+#3#3+' ('+cstr(f.blocks div 8)+'k, '+ctim(tooktime1)+ + ', '+cstr(cps)+' cps)'; + end; + sysoplog(s); + if ((incom) and (uls)) then begin + if (convt) then begin + lng:=origblocks*128; + star('Orig. file size: '+cstrl(lng)+' bytes.'); + end; + lng:=f.blocks; lng:=lng*128; + if (convt) then + star('New file size: '+cstrl(lng)+' bytes.') else + star('File size: '+cstrl(lng)+' bytes.'); + star('Upload time: '+longtim(tooktime)); + r2dt(convtime,convtime1); + if (convt) then + star('Convert time: '+longtim(convtime1)+' (not refunded)'); + star('Transfer rate: '+cstr(cps)+' cps'); + r2dt(ulrefundgot,ulrefundgot1); + star('Time refund: '+longtim(ulrefundgot1)+'.'); + if (gotpts<>0) then + star('File points: '+cstr(gotpts)+' pts.'); + nl; + if (choptime<>0.0) then begin + choptime:=choptime+ulrefundgot; + freetime:=freetime-ulrefundgot; + star('Sorry, no upload time refund may be given at this time.'); + star('You will get your refund after the event.'); + nl; + end; + doul(gotpts); + end + else star('Entry added.'); + end; + end; + if (not ok) and (not offline) then begin + if (exist(memuboard.ulpath+fn)) then begin + star('Upload not received.'); + s:='file deleted'; + if ((thisuser.sl>0 {systat.minresumelatersl} ) and + (f.blocks div 8>systat.minresume)) then begin + nl; + dyny:=TRUE; + if pynq('Save file for a later resume? ') then begin + doffstuff(f,fn,gotpts); + f.filestat:=f.filestat+[resumelater]; + if (not aexists) or (rn=0) then newff(f,v) else writefv(rn,f,v); + s:='file saved for later resume'; + end; + end; + if (not (resumelater in f.filestat)) then begin + if (exist(memuboard.ulpath+fn)) then begin + assign(fi,memuboard.ulpath+fn); + {$I-} erase(fi); {$I+} + end; + end; + sysoplog(#3#3+'Error uploading "'+sqoutsp(fn)+'" - '+s); + end; + star('Taking away time refund of '+ctim(ulrefundgot)+' minutes.'); + freetime:=freetime-ulrefundgot; + end; + if (offline) then begin + f.blocks:=10; + doffstuff(f,fn,gotpts); + f.filestat:=f.filestat+[isrequest]; + newff(f,v); + end; + close(ulff); + fileboard:=oldboard; + fiscan(pl); close(ulff); +end; + +procedure iul; +var s:astr; + pl:integer; + c:char; + abort,done,addbatch:boolean; +begin + fiscan(pl); + if (badulpath) then exit; + if (not aacs(memuboard.ulacs)) then begin + nl; star('You cannot upload to this section.'); + exit; + end; + locbatup:=FALSE; + if (incom) then printf('upload'); + nl; + repeat + sprint(fstring.uploadline); + done:=TRUE; addbatch:=FALSE; + nl; + prt('Filename: '); mpl(12); input(s,12); s:=sqoutsp(s); + if (s<>'') then + if (not fso) then ul(abort,s,addbatch) + else begin + if (not iswildcard(s)) then ul(abort,s,addbatch) + else begin + locbatup:=TRUE; + ffile(memuboard.ulpath+s); + if (not found) then print('No files found.') else + repeat + if not ((dirinfo.attr and VolumeID=VolumeID) or + (dirinfo.attr and Directory=Directory)) then + ul(abort,dirinfo.name,addbatch); + nfile; + until (not found) or (abort); + end; + end; + done:=(not addbatch); + until (done) or (hangup); +end; + +procedure fbaselist; +var s,os:astr; + onlin,nd,b,b2,i:integer; + abort,next,acc,showtitles:boolean; + + procedure titles; + var sep:astr; + begin + sep:=#3#4+':'+#3#3; + if (showtitles) then begin + sprint(#3#3+'NNN'+sep+'Flags '+sep+'Arc'+sep+'Description'); + sprint(#3#4+'===:=================:===:========================================'); + showtitles:=FALSE; + end; + end; + + procedure longlist; + begin + nl; + showtitles:=TRUE; + while (b<=maxulb) and (not abort) do begin + acc:=fbaseac(b); { fbaseac will load memuboard } + if ((fbunhidden in memuboard.fbstat) or (acc)) then begin + titles; + if (acc) then begin + s:=#3#5+cstr(ccuboards[1][b]); + while (length(s)<6) do s:=s+' '; + if (b in zscanr.fzscan) then s:=s+#3#9+'Scan ' else s:=s+#3#9+' '; + end else + s:=#3#9+' '; + if (fbnoratio in memuboard.fbstat) then s:=s+'No-Ratio ' + else s:=s+' '; + if (fbusegifspecs in memuboard.fbstat) then s:=s+'GIF ' + else s:=s+' '; + if (memuboard.arctype=0) then s:=s+#3#3+' ' + else s:=s+#3#3+allcaps(systat.filearcinfo[memuboard.arctype].ext); + s:=s+' '+#3#5+memuboard.name; + sprint(s); + inc(nd); + if (not empty) then wkey(abort,next); + end; + inc(b); + end; + end; + + procedure shortlist; + begin + nl; + while (b<=maxulb) and (not abort) do begin + acc:=fbaseac(b); { fbaseac will load memuboard } + if ((fbunhidden in memuboard.fbstat) or (acc)) then begin + if (acc) then begin + b2:=ccuboards[1][b]; + s:=#3#5+cstr(b2); if (b2<10) then s:=' '+s; + if (b in zscanr.fzscan) then s:=s+'* ' else s:=s+' '; + end else + s:=' '; + s:=s+{#3#5+}memuboard.name; + if (fbnoratio in memuboard.fbstat) then s:=s+#3#5+' '; + inc(onlin); inc(nd); + if (onlin=1) then begin + if (thisuser.linelen>=80) and (b40) then + s:=mlnmci(s,40); + sprompt(s); os:=s; + end else begin + i:=40-lennmci(os); os:=''; + if (thisuser.linelen>=80) then begin + while (lennmci(os)38) then s:=mlnmci(s,38); + end else + nl; + sprint(os+s); + onlin:=0; + end; + if (not empty) then wkey(abort,next); + end; + inc(b); + end; + if (onlin=1) and (thisuser.linelen>=80) then nl; + end; + +begin + nl; + abort:=FALSE; + onlin:=0; s:=''; b:=0; nd:=0; + if pynq('Display detailed area listing? ') then longlist else shortlist; + if (nd=0) then sprompt(#3#7+'No file bases available.'); +end; + +procedure unlisted_download(s:astr); +var dok,kabort:boolean; + pl,oldnumbatchfiles,oldfileboard:integer; +begin + if (s<>'') then begin + if (not exist(s)) then print('File not found.') + else if (iswildcard(s)) then print('Can''t specify wildcards.') + else begin + oldnumbatchfiles:=numbatchfiles; + oldfileboard:=fileboard; fileboard:=-1; + send1(s,dok,kabort); + if (numbatchfiles=oldnumbatchfiles) and (dok) and (not kabort) then + dodl(5); + fileboard:=oldfileboard; + end; + end; +end; + +procedure do_unlisted_download; +var s:astr; +begin + nl; + print('Enter file name to download (d:path\filename.ext)'); + prt(':'); mpl(78); input(s,78); + unlisted_download(s); +end; + +function nfvpointer:longint; +var i,x:integer; + v:verbrec; + vfo:boolean; +begin + vfo:=(filerec(verbf).mode<>fmclosed); + if (not vfo) then reset(verbf); + x:=filesize(verbf); + for i:=0 to filesize(verbf)-1 do begin + seek(verbf,i); read(verbf,v); + if (v.descr[1]='') then x:=i; + end; + if (not vfo) then close(verbf); + nfvpointer:=x; +end; + +end. diff --git a/file10.pas b/file10.pas new file mode 100644 index 0000000..1141841 --- /dev/null +++ b/file10.pas @@ -0,0 +1,549 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file10; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + file0, file1, file2, file4, file9, + common; + +procedure move; +procedure editfiles; +procedure validatefiles; + +implementation + +uses + miscx; + +procedure move; +var ff:file; + f,f1:ulfrec; + v:verbrec; + s,s1,s2,fl,fn:astr; + x,i:longint; + pl,rn,dbn,oldfileboard:integer; + c:char; + espace,nospace,done,abort,next,ok:boolean; +begin + nl; + print('Move files.'); + gfn(fn); abort:=FALSE; next:=FALSE; + nl; + recno(fn,pl,rn); + if (baddlpath) then exit; + if (fn='') or (pos('.',fn)=0) or (rn=0) then + print('No matching files.') + else begin + lastcommandovr:=TRUE; + c:=#0; + while (rn<>0) and (pl<>0) and (rn<=pl) and + (not abort) and (not hangup) do begin + if (rn<>0) and (pl<>0) then begin + seek(ulff,rn); read(ulff,f); + if (c<>'?') then begin + nl; + fileinfo(f,FALSE,abort,next); + nl; + end; + if (next) then c:='N' else begin + prt('Move files (?=help) : '); onek(c,'QMN?'^M); + end; + case c of + ^M:c:=#0; {* do nothing *} + '?':begin + nl; + print('Redisplay entry'); + lcmds(10,3,'Move file','Next file'); + lcmds(10,3,'Quit',''); + nl; + end; + 'M':begin + done:=FALSE; + nl; + repeat + prt('Move file (Q=Quit,?=List,#=Move-to base) : '); + input(s,3); dbn:=ccuboards[0][value(s)]; + if (s='?') then begin fbaselist; nl; end else + if (s='Q') or ((dbn=0) and (s<>'0')) then done:=TRUE else + if (dbn<0) or (dbn>maxulb) then print('Can''t move it there.') + else begin + oldfileboard:=fileboard; + changefileboard(dbn); + if (fileboard=oldfileboard) then print('Can''t move it there.') + else begin + fileboard:=oldfileboard; + done:=TRUE; + nl; + loaduboard(fileboard); + fl:=memuboard.dlpath+f.filename; + s1:=fexpand(bslash(FALSE,memuboard.dlpath)); + loaduboard(dbn); + sprint(#3#5+'Moving file ... to '+memuboard.name+#3#5); + s2:=fexpand(bslash(FALSE,memuboard.dlpath)); + ok:=TRUE; + + sprint(#3#5+'Orig-path : "'+s1+'" ('+cstrl(freek(exdrv(s1)))+'k free)'); + sprint(#3#5+'Dest-path : "'+s2+'" ('+cstrl(freek(exdrv(s2)))+'k free)'); + + if (s1=s2) then begin + sprint(#3#7+'No move: directory paths are the same.'); + espace:=TRUE; + ok:=TRUE; + end else + if (exist(fl)) then begin + espace:=TRUE; + assign(ff,fl); + {$I-} + reset(ff,1); i:=trunc(filesize(ff)/1024.0)+1; + close(ff); + {$I+} + x:=exdrv(memuboard.dlpath); (* uboards[dbn] *) + sprompt(#3#5+'Progress: '); + movefile(ok,nospace,TRUE,fl, + memuboard.dlpath+f.filename); + (* ^^^^^^^^^ uboards[dbn] *) + if (ok) then nl; + if (not ok) then begin + sprompt(#3#7+'Move failed'); + if (not nospace) then nl else + sprompt(' - Insuffient space on drive '+chr(x+64)+':'); + sprint('!'); + end; + end else + print('File does not actually exist.'); + if ((espace) and (ok)) or (not exist(fl)) then begin + sprompt(#3#5+'Moving file record ...'); + deleteff(rn,pl,FALSE); + oldfileboard:=fileboard; fileboard:=dbn; + + close(ulff); fiscan(pl); + if (baddlpath) then exit; + v.descr[1]:=#1#1#0#1#1; + newff(f,v); close(ulff); + + fileboard:=oldfileboard; + fiscan(pl); + if (baddlpath) then exit; + sysoplog('Moved "'+sqoutsp(f.filename)+'" from Dir#'+ + cstr(fileboard)+' to Dir#'+cstr(dbn)); + end; + nl; + c:='N'; + dec(rn); dec(lrn); + end; + end; + until ((done) or (hangup)); + end; + end; + if (c<>'?') then nrecno(fn,pl,rn); + abort:=FALSE; next:=FALSE; + if (c='Q') then abort:=TRUE; + end; + end; + close(ulff); + end; +end; + +procedure creditfile(var u:userrec; un:integer; var f:ulfrec; credit:boolean); +var rfpts:real; + gotpts:longint; +begin + if (not systat.fileptratio) then + gotpts:=0 + else begin + rfpts:=(f.blocks/8)/systat.fileptcompbasesize; + gotpts:=round(rfpts*systat.fileptcomp); + if (gotpts<1) then gotpts:=1; + end; + if (credit) then + sprompt(#3#5+'Awarding upload credits: ') + else + sprompt(#3#5+'Taking away upload credits: '); + prompt('1 file, '+cstrl(f.blocks div 8)+'k'); + if (credit) then begin + inc(u.uploads); + inc(u.uk,f.blocks div 8); + end else begin + dec(u.uploads); + dec(u.uk,f.blocks div 8); + end; + if (systat.fileptratio) then begin + prompt(', '+cstrl(gotpts)+' file points'); + if (credit) then + inc(u.filepoints,gotpts) + else + dec(u.filepoints,gotpts); + end; + print('.'); + saveurec(u,un); + if (un=usernum) then showudstats; +end; + +procedure editfiles; +var ff:file; + u:userrec; + f,f1:ulfrec; + v:verbrec; + fn,fd,s,sel:astr; + fsize:longint; + pl,rn,i,x:integer; + c,c1:char; + dontshowlist,done,done2,abort,next:boolean; +begin + nl; + print('Edit files.'); + gfn(fn); abort:=FALSE; next:=FALSE; + nl; + dontshowlist:=FALSE; + recno(fn,pl,rn); + if (baddlpath) then exit; + if (fn='') or (pos('.',fn)=0) or (rn=0) then + print('No matching files.') + else begin + lastcommandovr:=TRUE; + while (rn<>0) and (not abort) and (not hangup) do begin + if rn<>0 then begin + repeat + seek(ulff,rn); read(ulff,f); + abort:=FALSE; next:=FALSE; + if not dontshowlist then begin + nl; + fileinfo(f,TRUE,abort,next); + end else + dontshowlist:=FALSE; + nl; + abort:=FALSE; + if (next) then c:='N' else begin + prt('Edit files (?=help) : '); + onek(c,'Q?1234567CMRTVWN'^M); nl; + end; + case c of + '?':begin + sprint('1-7:Edit file record'); + lcmds(16,3,'Next record','Change Uploader''s file points'); + lcmds(16,3,'Verbose edit','Make request file'); + lcmds(16,3,'Resume toggle','Toggle validation'); + lcmds(16,3,'Withdraw credit','Quit'); + dontshowlist:=TRUE; + end; + '1':begin + prt('New filename: '); mpl(12); input(fn,12); + if (fn<>'') then begin + if ((exist(memuboard.dlpath+fn)) and + (exist(memuboard.dlpath+sqoutsp(f.filename)))) then + print('Can''t use that filename.') + else begin + assign(ff,memuboard.dlpath+f.filename); + {$I-} rename(ff,memuboard.dlpath+fn); {$I+} + x:=ioresult; + f.filename:=align(fn); + end; + end; + end; + '2':begin + print('Enter new description'); + prt(':'); mpl(60); inputl(s,60); + if s<>'' then f.description:=s; + end; + '3':begin + print('Change file size'); + nl; + prt('Use which: [B]ytes [K]Bytes [X]modem-blocks :'); + onek(c,'QBKX'^M); + + if (c in ['B','K','X']) then begin + prt('New file size in '); + case c of + 'B':prt('bytes: '); + 'K':prt('Kbytes: '); + 'X':prt('Xmodem blocks: '); + end; + mpl(8); input(s,8); + if (s<>'') then begin + val(s,fsize,x); + case c of + 'B':f.blocks:=fsize div 128; + 'K':f.blocks:=fsize*8; + 'X':f.blocks:=fsize; + end; + end; + end; + end; + '4':begin + prt('New user name/# who uploaded it: '); finduser(s,x); + if (x=0) then print('This user does not exist.'); + if (x<>0) then begin + f.owner:=x; + loadurec(u,x); + f.stowner:=allcaps(u.name); + end; + end; + '5':begin + prt('New upload file date: '); mpl(8); input(s,8); + if (s<>'') then begin f.date:=s; f.daten:=daynum(s); end; + end; + '6':begin + prt('New number of downloads: '); mpl(5); input(s,5); + if (s<>'') then f.nacc:=value(s); + end; + '7':begin + prt('Enter new amount of file points: '); mpl(5); input(s,5); + if (s<>'') then f.filepoints:=value(s); + end; + 'C':begin + loadurec(u,f.owner); + print('Add/Subtract from Uploader''s file points.'); + print('Current file points: '+cstr(u.filepoints)); + nl; + prt('Change value: '); mpl(6); input(s,6); + if (s<>'') then begin + inc(u.filepoints,value(s)); + saveurec(u,f.owner); + end; + end; + 'M':with f do + if (isrequest in filestat) then filestat:=filestat-[isrequest] + else filestat:=filestat+[isrequest]; + 'R':with f do + if (resumelater in filestat) then filestat:=filestat-[resumelater] + else filestat:=filestat+[resumelater]; + 'T':begin + with f do + if (notval in filestat) then filestat:=filestat-[notval] + else filestat:=filestat+[notval]; + + loadurec(u,f.owner); + + if (not aacs1(u,f.owner,systat.ulvalreq)) then + creditfile(u,f.owner,f,not (notval in f.filestat)); + end; + 'V':begin + if (f.vpointer=-1) then begin + print('There is no verbose entry for this file.'); + if pynq('Create verbose entry? ') then begin + v.descr[1]:=''; + f.vpointer:=nfvpointer; + assign(verbf,systat.gfilepath+'verbose.dat'); + reset(verbf); seek(verbf,f.vpointer); write(verbf,v); + reset(verbf); + end; + end; + if (f.vpointer<>-1) then begin + dontshowlist:=FALSE; + repeat + if (not dontshowlist) then begin + nl; + verbfileinfo(f.vpointer,TRUE,abort,next); + reset(verbf); seek(verbf,f.vpointer); read(verbf,v); + nl; + end; + dontshowlist:=FALSE; + sel:=^M'Q?DP'; + for x:=1 to 4 do begin + sel:=sel+chr(x+48); + if v.descr[x]='' then x:=4; + end; + prt('Verbose edit: (1-'+sel[length(sel)]+',D,P,?,Q) :'); + onek(c1,sel); nl; + case c1 of + '?':begin + print('1-'+sel[length(sel)]+':Edit verbose line'); + lcmds(20,3,'Delete this entry','Pointer value change'); + lcmds(20,3,'Quit',''); + nl; + dontshowlist:=TRUE; + end; + '1'..'4': + begin + prt('Enter new line:'); nl; + prt(':'); mpl(50); inputl(s,50); + if (s<>'') then begin + if (s=' ') then + if pynq('Set to NULL string? ') then s:=''; + v.descr[ord(c1)-48]:=s; + if (c1=sel[length(sel)]) and (c1<>'4') then + v.descr[ord(c1)-47]:=''; + {$I-} seek(verbf,f.vpointer); {$I+} + if (ioresult=0) then write(verbf,v); + end; + end; + 'D':if pynq('Are you sure? ') then begin + v.descr[1]:=''; + {$I-} seek(verbf,f.vpointer); {$I+} + if (ioresult=0) then write(verbf,v); + f.vpointer:=-1; + c1:='Q'; + end; + 'P':begin + print('Change pointer value.'); + print('Pointer range: 0-'+cstr(filesize(verbf)-1)); + print('(-1 makes inactive for this file without deleting any entries)'); + nl; + prt('New pointer value: '); + mpl(5); input(s,10); + if (s<>'') then begin + val(s,i,x); + if ((i>=-1) and (i<=filesize(verbf)-1)) then + f.vpointer:=i; + end; + end; + end; + until (c1 in ['Q',' ',^M]) or (hangup) or (f.vpointer=-1); + {$I-} close(verbf); {$I+} + if (ioresult<>0) then print('Errors closing VERBOSE.DAT'); + dontshowlist:=FALSE; + end; + end; + 'W':begin + loadurec(u,f.owner); + sprint(#3#0+'WARNING: '+#3#5+'If you have already withdrawn credit'); + sprint(#3#5+'from this user (or he never got it to begin with),'); + sprint(#3#5+'the user will lose even MORE upload credit than'); + sprint(#3#5+'they started out with!'); + nl; + if pynq('Withdraw credit?? ') then + creditfile(u,f.owner,f,FALSE); + end; + else + next:=TRUE; + end; + seek(ulff,rn); write(ulff,f); + until (c in ['Q',' ']) or (hangup) or (next); + if (c='Q') then abort:=TRUE; + end; + nrecno(fn,pl,rn); + end; + close(ulff); + end; +end; + +procedure validatefiles; +var i:integer; + c:char; + abort,next,isglobal,ispoints,isprompt:boolean; + + procedure valfiles(b:integer; var abort,next:boolean); + var u:userrec; + f:ulfrec; + s:astr; + lng:longint; + oldboard,pl,rn:integer; + shownalready:boolean; + begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + recno('*.*',pl,rn); + shownalready:=FALSE; abort:=FALSE; next:=FALSE; + while (rn<>0) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + if (notval in f.filestat) and + (not (resumelater in f.filestat)) then begin + if (not shownalready) then begin + nl; + sprint('Validating '+#3#5+memuboard.name+#3#5+' #'+ + cstr(fileboard)); (*+#3#1+' ('+memuboard.dlpath+')');*) + nl; + shownalready:=TRUE; + end; + + lng:=f.blocks; lng:=lng*128; + sprint('Filename : '+#3#3+'"'+f.filename+'"'); + sprint('Description: '+#3#3+f.description); + sprint('Size/points: '+#3#5+cstrl(lng)+' bytes / '+ + cstr(f.filepoints)+' pts'); + sprint('UL''d by : '+#3#9+caps(f.stowner)+' #'+cstr(f.owner)); + nl; + loadurec(u,f.owner); + if (isprompt) then begin + if (ispoints) then begin + prt('Points for file (=Skip,Q=Quit) : '); input(s,5); + if (s='Q') then abort:=TRUE; + if ((s<>'') and (s<>'Q')) then begin + f.filepoints:=value(s); + f.filestat:=f.filestat-[notval]; + seek(ulff,rn); write(ulff,f); + if (not aacs1(u,f.owner,systat.ulvalreq)) then + creditfile(u,f.owner,f,TRUE); + prt('Points for '+#3#5+caps(f.stowner)+' #'+ + cstr(f.owner)+#3#4+' (-999..999) : '); + input(s,5); + if (s<>'') then + if (f.owner=usernum) then + inc(thisuser.filepoints,value(s)) + else begin + inc(u.filepoints,value(s)); + saveurec(u,f.owner); + end; + end; + nl; + end else begin + repeat + ynq('Validate? (Y/N,V=View,Q=Quit) : '); onek(c,'QNVY'); + case c of + 'Q':abort:=TRUE; + 'V':begin + abort:=FALSE; next:=FALSE; + lfi(sqoutsp(memuboard.dlpath+f.filename),abort,next); + abort:=FALSE; next:=FALSE; + end; + 'Y':begin + f.filestat:=f.filestat-[notval]; + seek(ulff,rn); write(ulff,f); + if (not aacs1(u,f.owner,systat.ulvalreq)) then + creditfile(u,f.owner,f,TRUE); + end; + end; + until ((c<>'V') or (hangup)); + nl; + end; + end else begin + f.filestat:=f.filestat-[notval]; + seek(ulff,rn); write(ulff,f); + if (not aacs1(u,f.owner,systat.ulvalreq)) then + creditfile(u,f.owner,f,TRUE); + end; + end; + + nrecno('*.*',pl,rn); + wkey(abort,next); + end; + close(ulff); + end; + fileboard:=oldboard; + end; + +begin + nl; + print('Validate files -'); + nl; + ynq('Prompt for validation? (Y)es, (N)o, (P)oints validation : '); + onek(c,'QNPY'); + if (c='Q') then exit; + + ispoints:=(c='P'); + isprompt:=(c<>'N'); + isglobal:=pynq('Search all directories? '); + nl; + + abort:=FALSE; next:=FALSE; + if (isglobal) then begin + i:=0; + while (i<=maxulb) and (not abort) and (not hangup) do begin + if (fbaseac(i)) then valfiles(i,abort,next); + inc(i); + wkey(abort,next); + if (next) then abort:=FALSE; + end; + end else + valfiles(fileboard,abort,next); +end; + +end. diff --git a/file11.pas b/file11.pas new file mode 100644 index 0000000..2003c3a --- /dev/null +++ b/file11.pas @@ -0,0 +1,544 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file11; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + file0, file1, + common; + +function cansee(f:ulfrec):boolean; +procedure pbn(var abort,next:boolean); +procedure pfn(fnum:integer; f:ulfrec; var abort,next:boolean); +procedure searchb(b:integer; fn:astr; filestats:boolean; var abort,next:boolean); +procedure search; +procedure listfiles; +procedure searchbd(b:integer; ts:astr; var abort,next:boolean); +procedure searchd; +procedure newfiles(b:integer; var abort,next:boolean); +procedure gnfiles; +procedure nf(mstr:astr); +procedure fbasechange(var done:boolean; mstr:astr); +procedure createtempdir; +procedure fbasestats; + +implementation + +function cansee(f:ulfrec):boolean; +begin + cansee:=((not (notval in f.filestat)) or (aacs(systat.seeunval))); +end; + +function isulr:boolean; +begin + isulr:=((systat.uldlratio) and (not systat.fileptratio)); +end; + +procedure pbn(var abort,next:boolean); +var s,s1:astr; +begin + if (not bnp) then begin + printacr('',abort,next); + if (thisuser.flistopt<>30) then begin + printacr('',abort,next); + loaduboard(fileboard); + s:=#3#5+memuboard.name+' '+#3#2+'#'+#3#4+cstr(ccuboards[1][fileboard]); + s1:=#3#0; while (lenn(s1)'; + sprint(s); + sprint(s1); + end; + case thisuser.flistopt of + 1:if (isulr) then begin + printacr(#3#4+' Filename.Ext Bytes Description',abort,next); + printacr(#3#4+' -------- --- ------- -------------------------------------------------------', + abort,next); + end else begin + printacr(#3#4+' Filename.Ext Len Pts Description',abort,next); + printacr(#3#4+' -------- --- --- --- -------------------------------------------------------', + abort,next); + end; + 2,30:begin + s:=#3#4+' ###:Filename.Ext Bytes Pts DLs mm/dd/yy'; + s1:=#3#4+' ------------ --- ------- --- --- --------'; + if (aacs(memuboard.nameacs)) then begin + s:=s+' ULed By'; + s1:=s1+' -----------------------------------'; + end; + printacr(s,abort,next); + printacr(s1,abort,next); + end; + end; + end; + bnp:=TRUE; +end; + +procedure pfndd(fnum:integer; ts:astr; f:ulfrec; var abort,next:boolean); +var s,s1,dd,dd2:astr; + v:verbrec; + u:userrec; + li:longint; + i:integer; + vfo:boolean; + + function ptsf:astr; + begin + if (isrequest in f.filestat) then ptsf:=#3#9+'Offline' else + if (resumelater in f.filestat) then ptsf:=#3#7+'ResLatr' else + if (notval in f.filestat) then ptsf:=#3#8+'Unvalid' else + if ((isulr) and (f.filepoints=0)) then begin + li:=f.blocks; li:=li*128; + ptsf:=#3#4+mln(cstrl(li),7); + end else + ptsf:=#3#4+mln(cstr(f.blocks div 8),3)+' '+ + mln(cstr(f.filepoints),3); + end; + + function ptsf2:astr; + begin + if (isrequest in f.filestat) or (resumelater in f.filestat) or + (notval in f.filestat) then ptsf2:=ptsf+' ' + else begin + li:=f.blocks; li:=li*128; + ptsf2:=mln(cstrl(li),7)+' '+mln(cstr(f.filepoints),3); + end; + end; + + {rcg11172000 had to change this to get it compiling under Free Pascal...} + {function substone(iscaps:boolean; src,old,new:astr):astr;} + function substone(iscaps:boolean; src,old,_new:astr):astr; + var p:integer; + begin + if (old<>'') then begin + if (iscaps) then _new:=allcaps(_new); + p:=pos(allcaps(old),allcaps(src)); + if (p>0) then begin + insert(_new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substone:=src; + end; + +begin + loaduboard(fileboard); + case thisuser.flistopt of + 1:begin + dd:=f.description; + if (ts<>'') then dd:=substone(TRUE,dd,ts,#3#0+allcaps(ts)+#3#5); + if (f.daten>=daynum(newdate)) then s:=#3#8+'*' else s:=' '; + dd2:=f.filename; + if (ts<>'') then dd2:=substone(TRUE,dd2,ts,#3#0+allcaps(ts)+#3#3); + s:=s+#3#3+dd2+' '+ptsf+' '+#3#5; + s1:=copy(dd,1,55); + if (not flistverb) and (f.vpointer<>-1) then begin + if (lenn(dd)>52) then s1:=copy(dd,1,51)+#3#3+'+'; + s1:=s1+#3#9+'(v)'; + end else + if (lenn(dd)>54) then s1:=copy(dd,1,53)+#3#3+'+'; + if ((isgifext(f.filename)) and (isgifdesc(s1))) then begin + dd:=copy(s1,1,pos('c)',s1)+1); + dd2:=#3#3+copy(s1,1,pos('c)',s1)+1)+#3#5; + s1:=substone(FALSE,s1,dd,dd2); + end; + s:=s+s1; + end; + 2,30:begin + if (f.daten>=daynum(newdate)) then s:=#3#8+'*' else s:=' '; + s:=s+#3#3+mn(fnum,3)+#3#4+':'+#3#3+f.filename+' '+ptsf2+' '+ + #3#5+mln(cstr(f.nacc),3)+' '+#3#7+f.date; + if (aacs(memuboard.nameacs)) then + s:=s+' '+#3#9+caps(f.stowner)+' #'+cstr(f.owner); + end; + 3:begin + printacr('',abort,next); + + dd:=f.description; + if (ts<>'') then dd:=substone(TRUE,dd,ts,#3#0+allcaps(ts)+#3#5); + dd2:=f.filename; + if (ts<>'') then dd2:=substone(TRUE,dd2,ts,#3#0+allcaps(ts)+#3#3); + + if (f.daten>=daynum(newdate)) then s:=#3#8+'*' else s:=' '; + s:=s+#3#3+dd2+#3#4+':'+#3#4+mln(cstr(f.nacc)+' DLs',7)+#3#4+':'+ + #3#4+'ULed on '+f.date; + if (aacs(memuboard.nameacs)) then + s:=s+' by '+#3#9+caps(f.stowner)+' #'+cstr(f.owner); + printacr(s,abort,next); + + if (isrequest in f.filestat) then + s1:=#3#9+'File stored off-line' + else + if (resumelater in f.filestat) then + s1:=#3#7+'Resume-later file' + else + if (notval in f.filestat) then + s1:=#3#8+'Not validated yet' + else begin + li:=f.blocks; li:=li*128; + if ((isulr) and (f.filepoints=0)) then + s1:=#3#4+cstrl(li)+' bytes' + else + s1:=#3#4+cstrl(li)+' bytes, '+cstr(f.filepoints)+' pts'; + end; + s:=' '+mln(s1,20)+#3#4+':'+#3#5; + s1:=copy(dd,1,55); + if ((isgifext(f.filename)) and (isgifdesc(s1))) then begin + dd:=copy(s1,1,pos('c)',s1)+1); + dd2:=#3#3+copy(s1,1,pos('c)',s1)+1)+#3#5; + s1:=substone(FALSE,s1,dd,dd2); + end; + s:=s+s1; + end; + end; + printacr(s,abort,next); + if ((f.vpointer<>-1) and (flistverb) and (thisuser.flistopt in [1,3])) then begin + vfo:=(filerec(verbf).mode<>fmclosed); + {$I-} if (not vfo) then reset(verbf); {$I+} + if (ioresult=0) then begin + {$I-} seek(verbf,f.vpointer); read(verbf,v); {$I+} + if (ioresult=0) then + for i:=1 to 4 do + if (v.descr[i]='') then i:=4 + else begin + dd:=substone(TRUE,v.descr[i],ts,#3#0+allcaps(ts)+#3#4); + printacr(' '+#3#2+':'+#3#4+dd,abort,next); + end; + if (not vfo) then close(verbf); + end; + end; + if ((resumelater in f.filestat) and (f.owner=usernum)) then + printacr(#3#8+'>'+#3#7+'>> '+#3#3+'You '+#3#5+'MUST RESUME'+#3#3+ + ' this file to receive credit for it',abort,next); +end; + +procedure pfn(fnum:integer; f:ulfrec; var abort,next:boolean); +begin + pfndd(fnum,'',f,abort,next); +end; + +procedure searchb(b:integer; fn:astr; filestats:boolean; var abort,next:boolean); +var f:ulfrec; + li,totfils,totsize:longint; + oldboard,pl,rn:integer; +begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + totfils:=0; totsize:=0; + recno(fn,pl,rn); + if (baddlpath) then exit; + while ((rn<=pl) and (not abort) and (not hangup) and (rn<>0)) do begin + seek(ulff,rn); read(ulff,f); + if (cansee(f)) then begin + pbn(abort,next); + pfn(rn,f,abort,next); + if (filestats) then begin + inc(totfils); + li:=f.blocks; li:=li*128; inc(totsize,li); + end; + end; + nrecno(fn,pl,rn); + end; + if ((filestats) and (not abort) and (totfils>0)) then + if (thisuser.flistopt<>3) then begin + printacr(#3#4+' ------------ -------',abort,next); + printacr(#3#4+' '+mln(cstr(totfils)+' files',12)+' '+cstr(totsize)+' bytes total',abort,next); + end else begin + nl; + printacr(#3#4+cstr(totfils)+' files, '+cstr(totsize)+' bytes total.',abort,next); + end; + close(ulff); + end; + fileboard:=oldboard; +end; + +procedure search; +var fn:astr; + bn:integer; + abort,next:boolean; +begin + nl; + sprint(fstring.searchline); + sprint(fstring.pninfo); + nl; gfn(fn); + bn:=0; abort:=FALSE; next:=FALSE; + while (not abort) and (bn<=maxulb) and (not hangup) do begin + if (fbaseac(bn)) then searchb(bn,fn,FALSE,abort,next); + inc(bn); + wkey(abort,next); + if (next) then begin abort:=FALSE; next:=FALSE; end; + end; +end; + +procedure listfiles; +var fn:astr; + abort,next:boolean; +begin + nl; + sprint(fstring.listline); + gfn(fn); abort:=FALSE; + searchb(fileboard,fn,TRUE,abort,next); +end; + +procedure searchbd(b:integer; ts:astr; var abort,next:boolean); +var oldboard,pl,rn,i:integer; + f:ulfrec; + ok,vfo:boolean; + v:verbrec; +begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + vfo:=(filerec(verbf).mode<>fmclosed); + {$I-} if not vfo then reset(verbf); {$I+} + fiscan(pl); + if (baddlpath) then exit; + rn:=1; + while (rn<=pl) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + if (cansee(f)) then begin + ok:=((pos(ts,allcaps(f.description))<>0) or + (pos(ts,allcaps(f.filename))<>0)); + if (not ok) then + if (f.vpointer<>-1) then begin + {$I-} seek(verbf,f.vpointer); read(verbf,v); {$I+} + if (ioresult=0) then begin + i:=1; + while (v.descr[i]<>'') and (i<=4) and (not ok) do begin + if pos(ts,allcaps(v.descr[i]))<>0 then ok:=TRUE; + inc(i); + end; + end; + end; + end; + if (ok) then begin + pbn(abort,next); + pfndd(rn,ts,f,abort,next); + end; + inc(rn); + end; + close(ulff); + reset(verbf); close(verbf); + end; + fileboard:=oldboard; +end; + +procedure searchd; +var s:astr; + bn:integer; + abort,next:boolean; +begin + nl; + sprint(fstring.findline1); + nl; + sprint(fstring.findline2); + prt(':'); mpl(20); input(s,20); + if (s<>'') then begin + nl; print('Searching for "'+s+'"'); nl; + if pynq('Search all directories? ') then begin + bn:=0; abort:=FALSE; next:=FALSE; + while (not abort) and (bn<=maxulb) and (not hangup) do begin + if (fbaseac(bn)) then searchbd(bn,s,abort,next); + inc(bn); + wkey(abort,next); + if (next) then begin abort:=FALSE; next:=FALSE; end; + end; + end else begin + abort:=FALSE; next:=FALSE; + searchbd(fileboard,s,abort,next); + end; + end; +end; + +procedure newfiles(b:integer; var abort,next:boolean); +var f:ulfrec; + oldboard,pl,rn:integer; +begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + fiscan(pl); + if (baddlpath) then exit; + rn:=1; + while (rn<=pl) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + if ((cansee(f)) and (f.daten>=daynum(newdate))) or + ((notval in f.filestat) and (cansee(f))) then begin + pbn(abort,next); + pfn(rn,f,abort,next); + end; + inc(rn); + end; + close(ulff); + end; + fileboard:=oldboard; +end; + +procedure gnfiles; +var i:integer; + abort,next:boolean; +begin + sysoplog('NewScan of file bases'); + i:=0; + abort:=FALSE; next:=FALSE; + while (not abort) and (i<=maxulb) and (not hangup) do begin + if ((fbaseac(i)) and (i in zscanr.fzscan)) then newfiles(i,abort,next); + inc(i); + wkey(abort,next); + if (next) then begin abort:=FALSE; next:=FALSE; end; + end; +end; + +procedure nf(mstr:astr); +var bn:integer; + abort,next:boolean; +begin + if (mstr='C') then newfiles(board,abort,next) + else if (mstr='G') then gnfiles + else if (value(mstr)<>0) then newfiles(value(mstr),abort,next) + else begin + nl; + sprint(fstring.newline); + sprint(fstring.pninfo); + nl; + abort:=FALSE; next:=FALSE; + if pynq('Search all directories? ') then gnfiles + else newfiles(fileboard,abort,next); + end; +end; + +procedure fbasechange(var done:boolean; mstr:astr); +var s:astr; + i:integer; +begin + if (mstr<>'') then + case mstr[1] of + '+':begin + i:=fileboard; + if (fileboard>=maxulb) then i:=0 else + repeat + inc(i); + if (fbaseac(i)) then changefileboard(i); + until ((fileboard=i) or (i>maxulb)); + if (fileboard<>i) then sprint('@MHighest accessible file base.') + else lastcommandovr:=TRUE; + end; + '-':begin + i:=fileboard; + if (fileboard<=0) then i:=maxulb else + repeat + dec(i); + if fbaseac(i) then changefileboard(i); + until ((fileboard=i) or (i<=0)); + if (fileboard<>i) then sprint('@MLowest accessible file base.') + else lastcommandovr:=TRUE; + end; + 'L':fbaselist; + else + begin + changefileboard(value(mstr)); + if (pos(';',mstr)>0) then begin + s:=copy(mstr,pos(';',mstr)+1,length(mstr)); + curmenu:=systat.menupath+s+'.mnu'; + newmenutoload:=TRUE; + done:=TRUE; + end; + lastcommandovr:=TRUE; + end; + end + else begin + if (novice in thisuser.ac) then fbaselist; + nl; + s:='?'; + repeat + prt('^7Change file base (^3?^7=^3List^7) : '); input(s,3); + i:=ccuboards[0][value(s)]; + if (s='?') then begin fbaselist; nl; end else + if (((i>=1) and (i<=maxulb)) or + ((i=0) and (copy(s,1,1)='0'))) and + (i<>fileboard) then + changefileboard(i); + until (s<>'?') or (hangup); + lastcommandovr:=TRUE; + end; +end; + +procedure createtempdir; +var s:astr; + i:integer; +begin + nl; + if (maxulb=maxuboards) then print('Too many file bases already.') + else begin + print('Enter file path for temporary directory'); + prt(':'); mpl(40); input(s,40); + if (s<>'') then begin + s:=fexpand(bslash(TRUE,s)); + fileboard:=maxulb+1; + sysoplog('Created temporary directory #'+cstr(fileboard)+ + ' in "'+s+'"'); + with tempuboard do begin + name:='<< Temporary >>'; + filename:='TEMPFILE'; + dlpath:=s; + ulpath:=s; + maxfiles:=2000; + password:=''; + arctype:=0; + cmttype:=1; + fbdepth:=0; + fbstat:=[]; + acs:='s'+cstr(thisuser.sl)+'d'+cstr(thisuser.dsl); + ulacs:='s'+cstr(thisuser.sl)+'d'+cstr(thisuser.dsl); + nameacs:='s'+cstr(thisuser.sl)+'d'+cstr(thisuser.dsl); + for i:=1 to 6 do res[i]:=0; + end; + memuboard:=tempuboard; + end; + end; +end; + +procedure fbasestats; +var s:astr; + abort,next:boolean; + + procedure dd(var abort,next:boolean; s1,s2:astr; b:boolean); + begin + s1:=#3#3+s1+#3#5+' '; + if (b) then printacr(s1+s2,abort,next) + else printacr(s1+'None.',abort,next); + end; + +begin + abort:=FALSE; next:=FALSE; + nl; + loaduboard(fileboard); + with memuboard do begin + s:=#3#3+'Statistics on "'+#3#5+memuboard.name+' #'+ + cstr(ccuboards[1][fileboard])+#3#3+'"'; + if (fbnoratio in fbstat) then s:=s+#3#5+' '; + printacr(s,abort,next); + nl; +{ dd(abort,next,'AR requirement ....... :','"'+ar+'"',(ar<>'@'));} + dd(abort,next,'Base password ........ :','"'+password+'"',(password<>'')); +{ dd(abort,next,'SL requirement ....... :',cstr(sl)+' SL',(sl<>0));} +{ dd(abort,next,'DSL requirement ...... :',cstr(dsl)+' DSL',(dsl<>0));} + dd(abort,next,'Max files allowed .... :',cstr(maxfiles),(maxfiles<>0)); +{ dd(abort,next,'Age requirement ...... :',cstr(agereq),(agereq>1));} + s:=systat.filearcinfo[arctype].ext; + dd(abort,next,'Archive format ....... :','"'+s+'"',(arctype<>0)); + if (fso) then begin + nl; + dd(abort,next,'Filename ...... :','"'+filename+'.DIR"',TRUE); + dd(abort,next,'DL file path .. :','"'+dlpath+'"',TRUE); + end; + end; +end; + +end. diff --git a/file12.pas b/file12.pas new file mode 100644 index 0000000..1466760 --- /dev/null +++ b/file12.pas @@ -0,0 +1,516 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file12; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + file0, file1, file2, file4, file6, file9, + execbat, + mmodem, + common; + +procedure delubatch(n:integer); +procedure listubatchfiles; +procedure removeubatchfiles; +procedure clearubatch; +procedure batchul; +procedure batchinfo; + +implementation + +procedure delubatch(n:integer); +var c:integer; +begin + if ((n>=1) and (n<=numubatchfiles)) then begin + if (n<>numubatchfiles) then + for c:=n to numubatchfiles-1 do ubatch[c]:=ubatch[c+1]; + dec(numubatchfiles); + end; +end; + +procedure listubatchfiles; +var s,s1:astr; + i,j:integer; + abort,next,vfo:boolean; +begin + if (numubatchfiles=0) then begin + nl; print('Upload batch queue empty.'); + end else begin + abort:=FALSE; next:=FALSE; + nl; + printacr(#3#4+'##:Filename.Ext Area Description',abort,next); + printacr(#3#4+'--------------- ---- -------------------------------------------------------',abort,next); + + i:=1; + while ((not abort) and (i<=numubatchfiles) and (not hangup)) do begin + with ubatch[i] do begin + if (section=systat.tosysopdir) then s1:=#3#7+'Sysp' + else s1:=mrn(cstr(section),4); + s:=#3#3+mn(i,2)+#3#4+':'+#3#5+align(fn)+' '+s1+' '+ + #3#3+mln(description,55); + printacr(s,abort,next); + if (vr<>0) then + if (ubatchv[vr]^.descr[1]<>'') then begin + vfo:=(filerec(verbf).mode<>fmclosed); + if (not vfo) then reset(verbf); + if (ioresult=0) then + for j:=1 to 4 do + if ubatchv[vr]^.descr[j]='' then j:=4 else + printacr(' '+#3#2+':'+ + #3#4+ubatchv[vr]^.descr[j],abort,next); + if (not vfo) then close(verbf); + end; + end; + inc(i); + end; + + printacr(#3#4+'--------------- ---- -------------------------------------------------------',abort,next); + end; +end; + +procedure removeubatchfiles; +var s:astr; + i:integer; +begin + if (numubatchfiles=0) then begin + nl; print('Upload batch queue empty.'); + end else + repeat + nl; + prt('File # to remove (1-'+cstr(numubatchfiles)+') (?=list) : '); + input(s,2); i:=value(s); + if (s='?') then listubatchfiles; + if ((i>0) and (i<=numubatchfiles)) then begin + print('"'+stripname(ubatch[i].fn)+'" deleted out of upload queue.'); + delubatch(i); + end; + if (numubatchfiles=0) then print('Upload queue now empty.'); + until (s<>'?'); +end; + +procedure clearubatch; +begin + nl; + if pynq('Clear upload queue? ') then begin + numubatchfiles:=0; + print('Upload queue now empty.'); + end; +end; + +procedure batchul; +var fi:file of byte; + dirinfo:searchrec; + f:ulfrec; + v:verbrec; + xferstart,xferend,tooktime,takeawayulrefundgot1,ulrefundgot1:datetimerec; + tconvtime1,st1:datetimerec; + pc,fn,s:astr; + st,tconvtime,convtime,ulrefundgot,takeawayulrefundgot:real; + totb,totfils,totb1,totfils1,cps,lng,totpts:longint; + i,p,hua,pl,dbn,blks,gotpts,ubn,filsuled,oldboard,passn:integer; + c:char; + abort,ahangup,next,done,dok,kabort,wenttosysop,ok,convt, + beepafter,dothispass,fok,nospace,savpause:boolean; + + function notinubatch(fn:astr):boolean; + var i:integer; + begin + notinubatch:=FALSE; + for i:=1 to numubatchfiles do + if (sqoutsp(fn)=sqoutsp(ubatch[i].fn)) then exit; + notinubatch:=TRUE; + end; + + function ubatchnum(fn:astr):integer; + var i:integer; + begin + fn:=sqoutsp(fn); + ubatchnum:=0; + for i:=1 to numubatchfiles do + if (fn=sqoutsp(ubatch[i].fn)) then ubatchnum:=i; + end; + + function plural:string; + begin + if (totfils<>1) then plural:='s' else plural:=''; + end; + +begin + savpause:=(pause in thisuser.ac); + if (savpause) then thisuser.ac:=thisuser.ac-[pause]; + + oldboard:=fileboard; + beepafter:=FALSE; done:=FALSE; + nl; + if (numubatchfiles=0) then begin + printf('batchul0'); + if (nofile) then begin + print('Warning! No upload batch files specified yet.'); + print('If you continue, and batch upload files, you will have to'); + print('enter file descriptions for each file after the batch upload'); + print('is complete.'); + end; + end else begin + printf('batchul'); + if (nofile) then begin + print('If you batch upload files IN ADDITION to the files already'); + print('specified in your upload batch queue, you must enter file'); + print('descriptions for them after the batch upload is complete.'); + end; + end; + reset(xf); + done:=FALSE; + repeat + nl; + sprompt('^4Batch Protocol (^0?^4=^0list^4) : ^3'); mpkey(s); + if (s='?') then begin + nl; + showprots(TRUE,FALSE,TRUE,FALSE); + end else begin + p:=findprot(s,TRUE,FALSE,TRUE,FALSE); + if (p=-99) then print('Invalid entry.') else done:=TRUE; + end; + until (done) or (hangup); + if (p<>-10) then begin + seek(xf,p); read(xf,protocol); close(xf); + nl; + sprint(#3#7+'Hangup after transfer?'); + prt('[A]bort [N]o [Y]es [M]aybe : '); + if (not trm) then onek(c,'ANYM') else local_onek(c,'ANYM'); + hua:=pos(c,'ANYM'); + dok:=TRUE; + if (hua<>1) then begin + if (hua<>3) then begin + nl; + dyny:=TRUE; + beepafter:=pynq('Beep after transfer? '); + end; + + lil:=0; + nl; nl; + if (useron) then print('Ready to receive batch queue!'); + lil:=0; + + getdatetime(xferstart); + if (useron) then shel(caps(thisuser.name)+' is batch uploading!') + else shel('Receiving file(s)...'); + execbatch(dok,FALSE,'tgtemp1.bat','tgtest1.$$$',systat.temppath+'2\', + bproline1(protocol.ulcmd),-1); + shel2; + getdatetime(xferend); + timediff(tooktime,xferstart,xferend); + + showuserfileinfo; + + ulrefundgot:=(dt2r(tooktime))*(systat.ulrefund/100.0); + freetime:=freetime+ulrefundgot; + + {*****} + + lil:=0; + nl; + nl; + star('Batch upload transfer complete.'); + nl; + lil:=0; + + tconvtime:=0.0; takeawayulrefundgot:=0.0; + totb:=0; totfils:=0; totb1:=0; totfils1:=0; totpts:=0; + + findfirst(systat.temppath+'2\*.*',anyfile-directory,dirinfo); + while (doserror=0) do begin + inc(totfils1); + inc(totb1,dirinfo.size); + findnext(dirinfo); + end; + cps:=trunc(totb1/dt2r(tooktime)); + + abort:=FALSE; next:=FALSE; + + if (totfils1=0) then begin + star('No files detected! Transfer aborted.'); + exit; + end; + + case hua of + 3:hangup:=TRUE; + 4:begin + lil:=0; + nl; + nl; + print('System will automatically hang up in 30 seconds.'); + print('Hit [H] to hang up now, any other key to abort.'); + st:=timer; + while (tcheck(st,30)) and (empty) do; + if (empty) then hangup:=TRUE; + if (not empty) then + if (upcase(inkey)='H') then hangup:=TRUE; + lil:=0; + end; + end; + + ahangup:=FALSE; + if (hangup) then begin + if (spd<>'KB') then begin + commandline('Hanging up and taking phone off hook...'); + dophonehangup(FALSE); + dophoneoffhook(FALSE); + spd:='KB'; + end; + hangup:=FALSE; ahangup:=TRUE; + end; + + r2dt(ulrefundgot,ulrefundgot1); + if (not ahangup) then begin + prt('Press any key for upload stats : '); + if (beepafter) then begin + i:=1; + repeat + if (s<>time) then begin prompt(^G#0#0#0^G); s:=time; inc(i); end; + until ((i=30) or (not empty) or (hangup)); + end; + getkey(c); + for i:=1 to 33 do prompt(^H' '^H); + + print('Uploads detected:'); + nl; + dir(systat.temppath+'2\','*.*',TRUE); + nl; + star('# files uploaded: '+cstr(totfils1)+' files.'); + star('File size uploaded: '+cstrl(totb1)+' bytes.'); + star('Batch upload time: '+longtim(tooktime)+'.'); + star('Transfer rate: '+cstr(cps)+' cps'); + star('Time refund: '+longtim(ulrefundgot1)+'.'); + nl; + pausescr; + end; + + fiscan(pl); + + {* files not in upload batch queue are ONLY done during the first pass *} + {* files already in the upload batch queue done during the second pass *} + + for passn:=1 to 2 do begin + findfirst(systat.temppath+'2\*.*',anyfile-directory,dirinfo); + while (doserror=0) do begin + fn:=sqoutsp(dirinfo.name); + nl; + dothispass:=FALSE; + if (notinubatch(fn)) then begin + ubn:=0; + dothispass:=TRUE; + star('"'+fn+'" - File not in upload batch queue.'); + + close(ulff); fiscan(pl); + wenttosysop:=TRUE; + f.filename:=fn; + dodescrs(f,v,pl,wenttosysop); + if (ahangup) then begin + f.description:='Not in upload batch queue - hungup after transfer'; + f.vpointer:=-1; v.descr[1]:=''; + end; + if (not wenttosysop) then begin + nl; + done:=FALSE; + if (ahangup) then + dbn:=oldboard + else + repeat + prt('File base (?=List,#=File base) ['+cstr(ccuboards[1][oldboard])+'] : '); + input(s,3); dbn:=ccuboards[0][value(s)]; + if (s='?') then begin fbaselist; nl; end; + if (s='') then dbn:=oldboard; + if (not fbaseac(dbn)) then begin + print('Can''t put it there.'); + dbn:=-1; + end else + loaduboard(dbn); + if (exist(sqoutsp(memuboard.dlpath+fn))) then begin + print('"'+fn+'" already exists in that directory.'); + dbn:=-1; + end; + if (dbn<>-1) and (s<>'?') then done:=TRUE; + until ((done) or (hangup)); + fileboard:=dbn; + nl; + end; + end else + if (passn<>1) then begin + dothispass:=TRUE; + star('"'+fn+'" - File found.'); + ubn:=ubatchnum(fn); + f.description:=ubatch[ubn].description; + fileboard:=ubatch[ubn].section; + v.descr[1]:=''; + if (ubatch[ubn].vr<>0) then v:=ubatchv[ubatch[ubn].vr]^; + f.vpointer:=-1; + if (v.descr[1]<>'') then f.vpointer:=nfvpointer; + wenttosysop:=(fileboard=systat.tosysopdir); + end; + + if (dothispass) then begin + if (wenttosysop) then fileboard:=systat.tosysopdir; + + close(ulff); fiscan(pl); + + arcstuff(ok,convt,blks,convtime,TRUE,systat.temppath+'2\', + fn,f.description); + tconvtime:=tconvtime+convtime; f.blocks:=blks; + doffstuff(f,fn,gotpts); + + fok:=TRUE; + loaduboard(fileboard); + if (ok) then begin + star('Moving file to '+#3#5+memuboard.name); + sprompt(#3#5+'Progress: '); + movefile(fok,nospace,TRUE,systat.temppath+'2\'+fn,memuboard.dlpath+fn); + if (fok) then begin + nl; + newff(f,v); + star('"'+fn+'" successfully uploaded.'); + sysoplog(#3#3+'Batch uploaded "'+sqoutsp(fn)+'" on '+ + memuboard.name); + inc(totfils); + lng:=blks; lng:=lng*128; + inc(totb,lng); + inc(totpts,gotpts); + end else begin + star('Error moving file into directory - upload voided.'); + sysoplog(#3#3+'Error moving batch upload "'+sqoutsp(fn)+'" into directory'); + end; + end else begin + star('Upload not received.'); + if ((thisuser.sl>0 {systat.minresumelatersl} ) and + (f.blocks div 8>systat.minresume)) then begin + nl; + dyny:=TRUE; + if pynq('Save file for a later resume? ') then begin + sprompt(#3#5+'Progress: '); + movefile(fok,nospace,TRUE,systat.temppath+'2\'+fn,memuboard.dlpath+fn); + if (fok) then begin + nl; + doffstuff(f,fn,gotpts); + f.filestat:=f.filestat+[resumelater]; + newff(f,v); + s:='file saved for later resume'; + end else begin + star('Error moving file into directory - upload voided.'); + sysoplog(#3#3+'Error moving batch upload "'+sqoutsp(fn)+'" into directory'); + end; + end; + end; + if (not (resumelater in f.filestat)) then begin + s:='file deleted'; + assign(fi,systat.temppath+'2\'+fn); erase(fi); + end; + sysoplog(#3#3+'Errors batch uploading "'+sqoutsp(fn)+'" - '+s); + end; + + if (not ok) then begin + st:=(rte*f.blocks); + takeawayulrefundgot:=takeawayulrefundgot+st; + r2dt(st,st1); + star('Time refund of '+longtim(st1)+' will be taken away.'); + end else + if (ubn<>0) then delubatch(ubn); + end; + + findnext(dirinfo); + end; + end; + + close(ulff); + fileboard:=oldboard; + fiscan(pl); close(ulff); + + nl; + star('# files uploaded: '+cstr(totfils1)+' files.'); + if (totfils<>totfils1) then + star('Files successful: '+cstr(totfils)+' files.'); + star('File size uploaded: '+cstrl(totb1)+' bytes.'); + star('Batch upload time: '+longtim(tooktime)+'.'); + r2dt(tconvtime,tconvtime1); + if (tconvtime<>0.0) then + star('Total convert time: '+longtim(tconvtime1)+' (not refunded)'); + star('Transfer rate: '+cstr(cps)+' cps'); + nl; + r2dt(ulrefundgot,ulrefundgot1); + star('Time refund: '+longtim(ulrefundgot1)+'.'); + + inc(systat.todayzlog.uploads,totfils); + inc(systat.todayzlog.uk,totb1 div 1024); + if (aacs(systat.ulvalreq)) then begin + if (totpts<>0) then + star('File points: '+cstr(totpts)+' pts.'); + star('Upload credits got: '+cstr(totfils)+' files, '+cstr(totb1 div 1024)+'k.'); + nl; + star('Thanks for the file'+plural+', '+thisuser.name+'!'); + inc(thisuser.uploads,totfils); + inc(thisuser.filepoints,totpts); + thisuser.uk:=thisuser.uk+(totb1 div 1024); + end else begin + nl; + sprint(#3#5+'Thanks for the upload'+plural+', '+thisuser.name+'!'); + sprompt(#3#5+'You will receive file '); + if (systat.uldlratio) then + sprompt('credit') + else + sprompt('points'); + sprint(' as soon as the SysOp validates the file'+plural+'!'); + end; + nl; + + if (choptime<>0.0) then begin + choptime:=choptime+ulrefundgot; + freetime:=freetime-ulrefundgot; + star('Sorry, no upload time refund may be given at this time.'); + star('You will get your refund after the event.'); + nl; + end; + + if (takeawayulrefundgot<>0.0) then begin + nl; + r2dt(takeawayulrefundgot,takeawayulrefundgot1); + star('Taking away time refund of '+longtim(takeawayulrefundgot1)); + freetime:=freetime-takeawayulrefundgot; + end; + + if (ahangup) then begin + commandline('Hanging up phone again...'); + dophonehangup(FALSE); + hangup:=TRUE; + end; + + end; + end; + if (savpause) then thisuser.ac:=thisuser.ac+[pause]; +end; + +procedure batchinfo; +var anyyet:boolean; + + procedure sayit(s:string); + begin + if (not anyyet) then begin anyyet:=TRUE; nl; end; + sprint(s); + end; + +begin + anyyet:=FALSE; + if (numbatchfiles<>0) then + sayit(#3#9+'>> '+#3#3+'You have '+#3#5+cstr(numbatchfiles)+ + #3#3+' file'+aonoff(numbatchfiles<>1,'s','')+ + ' left in your download batch queue.'); + if (numubatchfiles<>0) then + sayit(#3#9+'>> '+#3#3+'You have '+#3#5+cstr(numubatchfiles)+ + #3#3+' file'+aonoff(numubatchfiles<>1,'s','')+ + ' left in your upload batch queue.'); +end; + +end. + diff --git a/file13.pas b/file13.pas new file mode 100644 index 0000000..4d4a42c --- /dev/null +++ b/file13.pas @@ -0,0 +1,317 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} + +unit file13; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + file0, file1, file2, + common; + +procedure sort; + +implementation + +var totfils,totbases:longint; + bubblesortend:integer; + sortt:char; + isascend:boolean; + +procedure switch(a,b:integer); +var f1,f2:ulfrec; +begin + seek(ulff,a); read(ulff,f1); + seek(ulff,b); read(ulff,f2); seek(ulff,b); write(ulff,f1); + seek(ulff,a); write(ulff,f2); +end; + +function greater(islesser,isequ:boolean; r1,r2:integer):boolean; +var f1,f2:ulfrec; + b,c:boolean; + + procedure figure1; + begin + case sortt of + 'B':if (isequ) then b:=(f1.description<=f2.description) + else b:=(f1.description=f2.description) + else b:=(f1.description>f2.description); + 'D':if (isequ) then b:=(f1.daten>=f2.daten) + else b:=(f1.daten>f2.daten); + 'E':if (isequ) then b:=(copy(f1.filename,10,3)>=copy(f2.filename,10,3)) + else b:=(copy(f1.filename,10,3)>copy(f2.filename,10,3)); + 'F':if (isequ) then b:=(f1.filepoints>=f2.filepoints) + else b:=(f1.filepoints>f2.filepoints); + 'N':if (isequ) then b:=(f1.filename>=f2.filename) + else b:=(f1.filename>f2.filename); + 'O':if (isequ) then b:=(f1.owner>=f2.owner) + else b:=(f1.owner>f2.owner); + 'S':if (isequ) then b:=(f1.blocks>=f2.blocks) + else b:=(f1.blocks>f2.blocks); + 'T':if (isequ) then b:=(f1.nacc>=f2.nacc) + else b:=(f1.nacc>f2.nacc); + end; + end; + +begin + if (r1b) then goto 20; + inc(c); +40: + inc(d); + if (b-eb) then goto 50; + inc(c); + goto 40; +70: + if (a-e+1=1) then goto 80; + for b:=e+1 to a do + for c:=e to (b-1) do begin + f:=b-c+e-1; + if (greater(TRUE,FALSE,f,f+1)) then begin + x:=f+1; + switch(f,x); + end; + end; +80: + e:=hold[d]; a:=pass[d]; + dec(d); + if (d=0) then exit; + goto 10; +end; + +procedure flipit(pl:integer); +var i:integer; +begin + for i:=1 to pl div 2 do switch(i,(pl-i)+1); +end; + +procedure bubblesort(pl:integer); +var f1,f2:ulfrec; + i,j,numdone:integer; + foundit:boolean; +begin + if (bubblesortend>pl) then bubblesortend:=pl; { should never happen, but...} + numdone:=0; + repeat + i:=(bubblesortend+1)-numdone; + foundit:=FALSE; + while ((i<=pl) and (not foundit)) do + if (greater(FALSE,TRUE,1,i)) then foundit:=TRUE else inc(i); + +{ while ((i<=pl) and (not greater(FALSE,TRUE,1,i))) do inc(i);} + seek(ulff,1); read(ulff,f1); + +{ (i-1) __(i) } +{ | / } + { x O + + + + + + + x x x x x x x ..... } + { x + + + + + + + x x x x x x x ..... } + for j:=1 to i-2 do begin + seek(ulff,j+1); read(ulff,f2); + seek(ulff,j); write(ulff,f2); + end; + + { x + + + + + + + O x x x x x x x ..... } + seek(ulff,i-1); write(ulff,f1); + inc(numdone); + until ((numdone>=bubblesortend)); + +end; + +function analysis(pl:integer):integer; +var i,j:integer; + c1,c2:boolean; +begin + analysis:=1; + c1:=TRUE; c2:=TRUE; + for i:=1 to pl-1 do begin + if (not greater(TRUE,TRUE,i,i+1)) then c1:=FALSE; { a } + if (not greater(FALSE,TRUE,i,i+1)) then c2:=FALSE; { d } + end; + if (c1) then analysis:=2; { list is backwards, so flip it } + if (c2) then analysis:=0; { list is already sorted } + if ((not c1) and (not c2)) then begin + c1:=FALSE; j:=0; + i:=pl-1; + while ((i>=1) and (not c1)) do begin + if (not greater(FALSE,TRUE,i,i+1)) then begin c1:=TRUE; j:=i; end; + dec(i); + end; + if ((c1) and (j/pl<0.15)) then begin + analysis:=3; + bubblesortend:=j; + end; + end; +end; + +procedure sortfiles(b:integer; var abort,next:boolean); +var s:string; + oldboard,pl,sortt:integer; +begin + oldboard:=fileboard; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + fiscan(pl); + seek(ulff,pl+1); truncate(ulff); + sprompt('Sorting '+#3#5+memuboard.name+#3#5+' #'+cstr(fileboard)+#3#1+ + ' ('+cstr(pl)+' files)'); + abort:=FALSE; next:=FALSE; + sortt:=analysis(pl); + case sortt of 0:s:='.'; 1:s:=#3#0+'*'; 2:s:=#3#9+'x'; 3:s:=#3#9+'*'; end; + sprint(s); + case sortt of + 0:; + 1:mainsort(pl); + 2:flipit(pl); + 3:bubblesort(pl); + end; + wkey(abort,next); + close(ulff); + inc(totbases); inc(totfils,pl); + end; + fileboard:=oldboard; +end; + +procedure sort; +var f:ulfrec; + sortstart,sortend,tooktime:datetimerec; + i:integer; + c:char; + global,abort,next,savepause:boolean; +begin + savepause:=(pause in thisuser.ac); + if (savepause) then thisuser.ac:=thisuser.ac-[pause]; + + repeat + nl; prt('Sorting method? (?=help) [N] : '); + onek(sortt,'QBDEFNOST?'^M); + if (sortt='?') then begin + nl; + lcmds(7,3,'Date','Brief description'); + lcmds(7,3,'Name','Extension'); + lcmds(7,3,'Owner','File points'); + lcmds(7,3,'Size','Times downloaded'); + lcmds(7,3,'Quit',''); + end; + until ((sortt<>'?') or (hangup)); + + if (sortt=^M) then sortt:='N'; + case sortt of + 'D','F','O','S','T':isascend:=FALSE; + 'Q':exit; + else + isascend:=TRUE; + end; + if (isascend) then c:='A' else c:='D'; + prt('Order: (^3A^4)scending (^3D^4)escending (^3Q^4)uit : ['+c+'] : '); + onek(c,'QADN'^M); + case c of + 'A':isascend:=TRUE; + 'D':isascend:=FALSE; + 'Q':exit; + end; + + nl; + global:=pynq('Sort all directories? '); + nl; + + totfils:=0; totbases:=0; + + getdatetime(sortstart); + abort:=FALSE; next:=FALSE; + if (not global) then + sortfiles(fileboard,abort,next) + else begin + i:=0; + while ((not abort) and (i<=maxulb) and (not hangup)) do begin + if (fbaseac(i)) then sortfiles(i,abort,next); + inc(i); + wkey(abort,next); + if (next) then abort:=FALSE; + end; + end; + getdatetime(sortend); + timediff(tooktime,sortstart,sortend); + + nl; + print('Sorted '+cstrl(totfils)+' file'+aonoff(totfils<>1,'s','')+ + ' in '+cstrl(totbases)+' base'+aonoff(totbases<>1,'s','')+ + ' - Took '+longtim(tooktime)); + + if (savepause) then thisuser.ac:=thisuser.ac+[pause]; +end; + +end. diff --git a/file14.pas b/file14.pas new file mode 100644 index 0000000..efb5649 --- /dev/null +++ b/file14.pas @@ -0,0 +1,118 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file14; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + file0, file11, + common; + +procedure getgifspecs(fn:astr; var sig:astr; var x,y,c:word); +procedure dogifspecs(fn:astr; var abort,next:boolean); +procedure addgifspecs; + +implementation + +procedure getgifspecs(fn:astr; var sig:astr; var x,y,c:word); +var f:file; + rec:array[1..11] of byte; + c1,i,numread:word; +begin + assign(f,fn); + {$I-} reset(f,1); {$I+} + if (ioresult<>0) then begin + sig:='NOTFOUND'; + exit; + end; + + blockread(f,rec,11,numread); + close(f); + + if (numread<>11) then begin + sig:='BADGIF'; + exit; + end; + + sig:=''; + for i:=1 to 6 do sig:=sig+chr(rec[i]); + + x:=rec[7]+rec[8]*256; + y:=rec[9]+rec[10]*256; + c1:=(rec[11] and 7)+1; + c:=1; + for i:=1 to c1 do c:=c*2; +end; + +procedure dogifspecs(fn:astr; var abort,next:boolean); +var s,sig:astr; + x,y,c:word; +begin + getgifspecs(fn,sig,x,y,c); + s:=#3#3+align(stripname(fn)); + if (sig='NOTFOUND') then + s:=s+' '+#3#7+'NOT FOUND' + else + s:=s+' '+#3#5+mln(cstrl(x)+'x'+cstrl(y),10)+' '+ + mln(cstr(c)+' colors',10)+' '+#3#7+sig; + printacr(s,abort,next); +end; + +procedure addgifspecs; +var f:ulfrec; + gifstart,gifend,tooktime:datetimerec; + s,sig:astr; + totfils:longint; + x,y,c:word; + pl,rn,savflistopt:integer; + abort,next:boolean; +begin + nl; + print('Adding GifSpecs to files -'); + nl; + recno('*.*',pl,rn); + if (baddlpath) then exit; + + savflistopt:=thisuser.flistopt; + + totfils:=0; abort:=FALSE; next:=FALSE; + getdatetime(gifstart); + + while (rn<>0) and (pl<>0) and (rn<=pl) and + (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + if ((isgifext(f.filename)) and (not isgifdesc(f.description))) then begin + getgifspecs(memuboard.dlpath+sqoutsp(f.filename),sig,x,y,c); + if (sig<>'NOTFOUND') then begin + s:='('+cstrl(x)+'x'+cstrl(y)+','+cstr(c)+'c) '; + f.description:=s+f.description; + if (length(f.description)>54) then + f.description:=copy(f.description,1,54); + seek(ulff,rn); write(ulff,f); + pfn(rn,f,abort,next); + inc(totfils); + end; + end; + nrecno('*.*',pl,rn); + wkey(abort,next); + end; + getdatetime(gifend); + timediff(tooktime,gifstart,gifend); + + thisuser.flistopt:=savflistopt; + + nl; + s:='Added GifSpecs to '+cstrl(totfils)+' file'; + if (totfils<>1) then s:=s+'s'; + s:=s+' - Took '+longtim(tooktime); + print(s); + + close(ulff); +end; + +end. diff --git a/file2.pas b/file2.pas new file mode 100644 index 0000000..bed1358 --- /dev/null +++ b/file2.pas @@ -0,0 +1,124 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file2; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + execbat, file0, + common; + +procedure copyfile(var ok,nospace:boolean; showprog:boolean; + srcname,destname:astr); +procedure movefile(var ok,nospace:boolean; showprog:boolean; + srcname,destname:astr); + +implementation + +procedure copyfile(var ok,nospace:boolean; showprog:boolean; + srcname,destname:astr); +var buffer:array[1..16384] of byte; + fs,dfs:longint; + nrec,i:integer; + src,dest:file; + + procedure dodate; + var r:registers; + od,ot,ha:integer; + begin + srcname:=srcname+#0; + destname:=destname+#0; + with r do begin + ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5700; msdos(dos.registers(r)); + od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(dos.registers(r)); + ax:=$3d02; ds:=seg(destname[1]); dx:=ofs(destname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(dos.registers(r)); + ax:=$3e00; bx:=ha; msdos(dos.registers(r)); + end; + end; + +begin + ok:=TRUE; nospace:=FALSE; + assign(src,srcname); + {$I-} reset(src,1); {$I+} + if (ioresult<>0) then begin ok:=FALSE; exit; end; + dfs:=freek(exdrv(destname)); + fs:=trunc(filesize(src)/1024.0)+1; + if (fs>=dfs) then begin + close(src); + nospace:=TRUE; ok:=FALSE; + exit; + end else begin + assign(dest,destname); + {$I-} rewrite(dest,1); {$I+} + if (ioresult<>0) then begin ok:=FALSE; exit; end; + if (showprog) then begin + cl(7); + for i:=1 to fs div 16 do prompt('.'); + for i:=1 to fs div 16 do prompt(^H); + cl(5); + end; + repeat + blockread(src,buffer,16384,nrec); + blockwrite(dest,buffer,nrec); + if (showprog) then prompt('o'); + until (nrec<16384); + if (showprog) then begin + for i:=1 to (fs div 16)+1 do prompt(^H); + for i:=1 to (fs div 16)+1 do prompt(' '); + for i:=1 to (fs div 16)+1 do prompt(^H); + sprompt('^7*^5DONE^7*'); + end; + close(dest); close(src); + dodate; + end; +end; + +{rcg11172000 had to change this to get it compiling under Free Pascal...} +{function substall(src,old,new:astr):astr;} +function substall(src,old,_new:astr):astr; +var p:integer; +begin + p:=1; + while p>0 do begin + p:=pos(old,src); + if p>0 then begin + insert(_new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substall:=src; +end; + +procedure movline(var src:astr; s1,s2:astr); +begin + src:=substall(src,'@F',s1); + src:=substall(src,'@I',s2); +end; + +procedure movefile(var ok,nospace:boolean; showprog:boolean; + srcname,destname:astr); +var dfs,dft:integer; + f:file; + s,s1,s2,s3,opath:astr; +begin + ok:=TRUE; nospace:=FALSE; + + getdir(0,opath); + assign(f,srcname); reset(f,1); + dft:=trunc(filesize(f)/1024.0)+1; close(f); + + dfs:=freek(exdrv(destname)); + copyfile(ok,nospace,showprog,srcname,destname); + if ((ok) and (not nospace)) then begin + {$I-} erase(f); {$I+} + end; + chdir(opath); +end; + +end. diff --git a/file3.pas b/file3.pas new file mode 100644 index 0000000..028833f --- /dev/null +++ b/file3.pas @@ -0,0 +1,191 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file3; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + file0, + common; + +procedure arc_proc(var fp:file; var abort,next:boolean); +procedure zoo_proc(var fp:file; var abort,next:boolean); +procedure lzh_proc(var fp:file; var abort,next:boolean); + +implementation + +uses file4; + +{*------------------------------------------------------------------------*} + +procedure arc_proc(var fp:file; var abort,next:boolean); +var arc:arcfilerec; + numread:word; + i,typ,stat:integer; + c:char; +begin + {* arc_proc - Process entry in ARC archive. + *} + + repeat + c:=getbyte(fp); + typ:=ord(getbyte(fp)); {* get storage method *} + case typ of + 0:exit; {* end of archive file *} + 1,2:out.typ:=2; {* Stored *} + 3,4:out.typ:=typ; {* Packed & Squeezed *} + 5,6,7:out.typ:=typ; {* crunched *} + 8,9,10:out.typ:=typ-2; {* Crunched, Squashed & Crushed *} + 30:out.typ:=0; {* Directory *} + 31:dec(level); {* end of dir (not displayed) *} + else + out.typ:=1; {* Unknown! *} + end; + if typ<>31 then begin {* get data from header *} + blockread(fp,arc,23,numread); if numread<>23 then abend(abort,next,errmsg[2]); + if abort then exit; + if typ=1 then {* type 1 didn't have c_size field *} + arc.u_size:=arc.c_size + else begin + blockread(fp,arc.u_size,4,numread); + if numread<>4 then abend(abort,next,errmsg[2]); + if abort then exit; + end; + i:=0; + repeat + inc(i); + out.filename[i]:=arc.filename[i-1]; + until (arc.filename[i]=#0) or (i=13); + out.filename[0]:=chr(i); + out.date:=arc.mod_date; + out.time:=arc.mod_time; + if typ=30 then begin + arc.c_size:=0; {* set file size entries *} + arc.u_size:=0; {* to 0 for directories *} + end; + out.csize:=arc.c_size; {* set file size entries *} + out.usize:=arc.u_size; {* for normal files *} + details(abort,next); if abort then exit; + if typ<>30 then begin + {$I-} seek(fp,filepos(fp)+arc.c_size); {$I+} {* seek to next entry *} + if ioresult<>0 then abend(abort,next,errmsg[4]); + if abort then exit; + end; + end; + until (c<>#$1a) or (aborted); + if not aborted then abend(abort,next,errmsg[3]); +end; + +{*------------------------------------------------------------------------*} + +procedure zoo_proc(var fp:file; var abort,next:boolean); +var zoo:zoofilerec; + zoo_longname,zoo_dirname:string[255]; + numread:word; + i,method:integer; + namlen,dirlen:byte; +begin + {* zoo_proc - Process entry in ZOO archive. + *} + + while (not aborted) do begin {* set up infinite loop (exit is within loop) *} + blockread(fp,zoo,56,numread); if numread<>56 then abend(abort,next,errmsg[2]); + if abort then exit; + if zoo.tag<>Z_TAG then abend(abort,next,errmsg[3]); {* abort if invalid tag *} + if (abort) or (zoo.next=0) then exit; + + namlen:=ord(getbyte(fp)); dirlen:=ord(getbyte(fp)); + zoo_longname:=''; zoo_dirname:=''; + if namlen>0 then + for i:=1 to namlen do {* get long filename *} + zoo_longname:=zoo_longname+getbyte(fp); + if dirlen>0 then begin + for i:=1 to dirlen do {* get directory name *} + zoo_dirname:=zoo_dirname+getbyte(fp); + if copy(zoo_dirname,length(zoo_dirname),1)<>'/' then + zoo_dirname:=zoo_dirname+'/'; + end; + if zoo_longname<>'' then out.filename:=zoo_longname + else begin + i:=0; + repeat + inc(i); + out.filename[i]:=zoo.fname[i-1]; + until (zoo.fname[i]=#0) or (i=13); + out.filename[0]:=chr(i); + out.filename:=zoo_dirname+out.filename; + end; + out.date:=zoo.mod_date; {* set up fields *} + out.time:=zoo.mod_time; + out.csize:=zoo.c_size; + out.usize:=zoo.u_size; + method:=zoo.method; + case method of + 0:out.typ:=2; {* Stored *} + 1:out.typ:=6; {* Crunched *} + else + out.typ:=1; {* Unknown! *} + end; + if not (zoo.deleted=1) then details(abort,next); + if abort then exit; + + {$I-} seek(fp,zoo.next); {$I+} {* seek to next entry *} + if ioresult<>0 then abend(abort,next,errmsg[4]); + if abort then exit; + end; +end; + +{*------------------------------------------------------------------------*} + +procedure lzh_proc(var fp:file; var abort,next:boolean); +var lzh:lzhfilerec; + numread:word; + i:integer; + c:char; +begin + {* lzh_proc - Process entry in LZH archive. + *} + + while (not aborted) do begin {* set up infinite loop (exit is within loop) *} + c:=getbyte(fp); + if (c=#0) then exit else lzh.h_length:=ord(c); + c:=getbyte(fp); + lzh.h_cksum:=ord(c); + blockread(fp,lzh.method,5,numread); if (numread<>5) then abend(abort,next,errmsg[2]); + if (abort) then exit; + if ((lzh.method[1]<>'-') or + (lzh.method[2]<>'l') or + (lzh.method[3]<>'h')) then abend(abort,next,errmsg[3]); + if (abort) then exit; + blockread(fp,lzh.c_size,15,numread); if (numread<>15) then abend(abort,next,errmsg[2]); + if (abort) then exit; + for i:=1 to lzh.f_length do out.filename[i]:=getbyte(fp); + out.filename[0]:=chr(lzh.f_length); + if (lzh.h_length-lzh.f_length=22) then begin + blockread(fp,lzh.crc,2,numread); if (numread<>2) then abend(abort,next,errmsg[2]); + if (abort) then exit; + end; + out.date:=lzh.mod_date; {* set up fields *} + out.time:=lzh.mod_time; + out.csize:=lzh.c_size; + out.usize:=lzh.u_size; + c:=lzh.method[4]; + case c of + '0':out.typ:=2; {* Stored *} + '1':out.typ:=14; {* Frozen *} + else + out.typ:=1; {* Unknown! *} + end; + details(abort,next); + + {$I-} seek(fp,filepos(fp)+lzh.c_size); {$I+} {* seek to next entry *} + if (ioresult<>0) then abend(abort,next,errmsg[4]); + if (abort) then exit; + end; +end; + +end. diff --git a/file4.pas b/file4.pas new file mode 100644 index 0000000..7378954 --- /dev/null +++ b/file4.pas @@ -0,0 +1,578 @@ +(* IFL - Interior File Listing Utility + * Copyright 1989 by Martin Pollard. All rights reserved. + * + * IFL produces a listing of files contained in an archive file. + * Archive formats supported by IFL include: + * + * ARC - Developed by System Enhancement Associates + * and enhanced by PKWARE (PKARC & PKPAK) + * and NoGate Consulting (PAK) + * LZH - Developed by Haruyasu Yoshizaki + * ZIP - Developed by PKWARE + * ZOO - Developed by Rahul Dhesi + * + * Version history: + * + * 1.00 02/11/89 Initial release. + * 1.10 02/24/89 1. Added support for archives created with SEA's + * ARC 6.x, which uses new header codes to support + * subdirectory archiving. + * 2. Restructured much of the code, which made no + * operational difference but resulted in a much + * "cleaner" source file. + * 3. Added automatic extension support. IFL will now + * cycle through all supported extensions until it + * finds the desired file. + * 1.20 03/15/89 1. Added ZOO archive support. + * 2. The message line above the headings was changed + * to "Archive contains the following + * files:". The drive and pathname is no longer + * displayed before the filename. + * 3. Fixed a minor bug in which a non-archive file + * may be mistaken for a ZIP archive file when the + * the first byte is "P" (0x50) but the second is + * not "K" (0x4B). + * 1.30 05/09/89 Added support for archive files created by LHARC + * (LZH format). + * 1.40 07/15/89 1. Made minor code changes to improve performance, + * particularly during automatic extension + * searching. + * 2. Added support for the Imploding compression + * method used in PKZIP v1.00. + * 3. Corrected errors in and updated documentation. + *) + +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file4; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + file0, file14, + common; + + +{rcg11172000 had to change this to get it compiling under Free Pascal...} +{function substall(src,old,new:astr):astr;} +function substall(src,old,_new:astr):astr; + +function getbyte(var fp:file):char; +procedure abend(var abort,next:boolean; message:string); +procedure details(var abort,next:boolean); +procedure lfi(fn:astr; var abort,next:boolean); +procedure lfin(rn:integer; var abort,next:boolean); +procedure lfii; + +const + L_SIG=$04034b50; {* ZIP local file header signature *} + C_SIG=$02014b50; {* ZIP central dir file header signature *} + E_SIG=$06054b50; {* ZIP end of central dir signature *} + Z_TAG=$fdc4a7dc; {* ZOO entry identifier *} + + EXTS=6; {* number of default extensions *} + + filext:array[0..EXTS-1] of string[4] = ( + '.ZIP', {* ZIP format archive *} + '.ARC', {* ARC format archive *} + '.PAK', {* ARC format archive (PAK.EXE) *} + '.ZOO', {* ZOO format archive *} + '.LZH', {* LZH format archive *} + '.ARK'); {* ARC format archive (CP/M ARK.COM) *} + + errmsg:array[0..5] of string[49] = ( + 'Unable to access specified file', + 'Unexpected end of file', + 'Unexpected read error', + 'Invalid header ID encountered', + 'Can''t find next entry in archive', + 'File is not in ZIP/ZOO/PAK/LZH/ARC archive format'); + + method:array[0..15] of string[9] = ( + 'Directory', {* Directory marker *} + 'Unknown! ', {* Unknown compression type *} + 'Stored ', {* No compression *} + 'Packed ', {* Repeat-byte compression *} + 'Squeezed ', {* Huffman with repeat-byte compression *} + 'crunched ', {* Obsolete LZW compression *} + 'Crunched ', {* LZW 9-12 bit with repeat-byte compression *} + 'Squashed ', {* LZW 9-13 bit compression *} + 'Crushed ', {* LZW 2-13 bit compression *} + 'Shrunk ', {* LZW 9-13 bit compression *} + 'Reduced 1', {* Probabilistic factor 1 compression *} + 'Reduced 2', {* Probabilistic factor 2 compression *} + 'Reduced 3', {* Probabilistic factor 3 compression *} + 'Reduced 4', {* Probabilistic factor 4 compression *} + 'Frozen ', {* Modified LZW/Huffman compression *} + 'Imploded '); {* Shannon-Fano tree compression *} + +type + arcfilerec=record {* structure of ARC archive file header *} + filename:array[0..12] of char; {* filename *} + c_size:longint; {* compressed size *} + mod_date:integer; {* last mod file date *} + mod_time:integer; {* last mod file time *} + crc:integer; {* CRC *} + u_size:longint; {* uncompressed size *} + end; + + zipfilerec=record {* structure of ZIP archive file header *} + version:integer; {* version needed to extract *} + bit_flag:integer; {* general purpose bit flag *} + method:integer; {* compression method *} + mod_time:integer; {* last mod file time *} + mod_date:integer; {* last mod file date *} + crc:longint; {* CRC-32 *} + c_size:longint; {* compressed size *} + u_size:longint; {* uncompressed size *} + f_length:integer; {* filename length *} + e_length:integer; {* extra field length *} + end; + + zoofilerec=record {* structure of ZOO archive file header *} + tag:longint; {* tag -- redundancy check *} + typ:byte; {* type of directory entry (always 1 for now) *} + method:byte; {* 0 = Stored, 1 = Crunched *} + next:longint; {* position of next directory entry *} + offset:longint; {* position of this file *} + mod_date:word; {* modification date (DOS format) *} + mod_time:word; {* modification time (DOS format) *} + crc:word; {* CRC *} + u_size:longint; {* uncompressed size *} + c_size:longint; {* compressed size *} + major_v:char; {* major version number *} + minor_v:char; {* minor version number *} + deleted:byte; {* 0 = active, 1 = deleted *} + struc:char; {* file structure if any *} + comment:longint; {* location of file comment (0 = none) *} + cmt_size:word; {* length of comment (0 = none) *} + fname:array[0..12] of char; {* filename *} + var_dirlen:integer; {* length of variable part of dir entry *} + tz:char; {* timezone where file was archived *} + dir_crc:word; {* CRC of directory entry *} + end; + lzhfilerec=record {* structure of LZH archive file header *} + h_length:byte; {* length of header *} + h_cksum:byte; {* checksum of header bytes *} + method:array[1..5] of char; {* compression type "-lh#-" *} + c_size:longint; {* compressed size *} + u_size:longint; {* uncompressed size *} + mod_time:integer;{* last mod file time *} + mod_date:integer;{* last mod file date *} + attrib:integer; {* file attributes *} + f_length:byte; {* length of filename *} + crc:integer; {* crc *} + end; + + outrec=record {* output information structure *} + filename:string[255]; {* output filename *} + date:integer; {* output date *} + time:integer; {* output time *} + typ:integer; {* output storage type *} + csize:longint; {* output compressed size *} + usize:longint; {* output uncompressed size *} + end; + +var + accum_csize:longint; {* compressed size accumulator *} + accum_usize:longint; {* uncompressed size accumulator *} + files:integer; {* number of files *} + level:integer; {* output directory level *} + filetype:integer; {* file type (1=ARC,2=ZIP,3=ZOO,4=LZH) *} + out:outrec; + aborted:boolean; + +implementation + +uses file3; + +{rcg11172000 had to change this to get it compiling under Free Pascal...} +{function substall(src,old,new:astr):astr;} +function substall(src,old,_new:astr):astr; +var p:integer; +begin + p:=1; + while p>0 do begin + p:=pos(old,src); + if p>0 then begin + insert(_new,src,p+length(old)); + delete(src,p,length(old)); + end; + end; + substall:=src; +end; + +procedure lbrl(fn:astr; var abort,next:boolean); +var f:file; + c,n,n1:integer; + x:record + st:byte; + name:array[1..8] of char; + ext:array[1..3] of char; + index,len:integer; + fil:array[1..16] of byte; + end; + i:astr; +begin + nl; + assign(f,fn); + reset(f,32); + blockread(f,x,1); + c:=x.len*4-1; + for n:=1 to c do begin + blockread(f,x,1); i:=''; + if (x.st=0) and not abort then begin + for n1:=1 to 8 do i:=i+x.name[n1]; + i:=i+'.'; + for n1:=1 to 3 do i:=i+x.ext[n1]; + i:=align(i)+' '+mrn(cstrr(x.len*128.0,10),7); + printacr(i,abort,next); + end; + end; + close(f); +end; + +function mnz(l:longint; w:integer):astr; +var s:astr; +begin + s:=cstrl(l); + while length(s)12) then dec(month,12); {* adjust for month > 12 *} + if (year>99) then dec(year,100); {* adjust for year > 1999 *} + if (hour>23) then dec(hour,24); {* adjust for hour > 23 *} + if (minute>59) then dec(minute,60); {* adjust for minute > 59 *} + + if (hour<12) then ampm:='a' else ampm:='p'; {* determine AM/PM *} + if (hour=0) then hour:=12; {* convert 24-hour to 12-hour *} + if (hour>12) then dec(hour,12); + + if (out.usize=0) then ratio:=0 else {* ratio is 0% for null-length file *} + ratio:=100-((out.csize*100) div out.usize); + if ratio>99 then ratio:=99; + + outp:=#3#4+mnr(out.usize,8)+' '+mnr(out.csize,8)+' '+mnr(ratio,2)+'% '+ + #3#9+mrn(method[typ],9)+' '+#3#7+mnr(month,2)+'-'+mnz(day,2)+'-'+ + mnz(year,2)+' '+mnr(hour,2)+':'+mnz(minute,2)+ampm+' '+#3#5; + + if (level>0) then outp:=outp+mrn('',level); {* spaces for dirs (ARC only)*} + + outp:=outp+out.filename; + printacr(outp,abort,next); + + if (typ=0) then inc(level) {* bump dir level (ARC only) *} + else begin + inc(accum_csize,out.csize); {* adjust accumulators and counter *} + inc(accum_usize,out.usize); + inc(files); + end; +end; + +{*------------------------------------------------------------------------*} + +procedure final(var abort,next:boolean); +var outp:string; + ratio:longint; +begin + {* final - Display final totals and information. + *} + + if accum_usize=0 then ratio:=0 {* ratio is 0% if null total length *} + else + ratio:=100-((accum_csize*100) div accum_usize); + if ratio>99 then ratio:=99; + + outp:=#3#4+mnr(accum_usize,8)+' '+mnr(accum_csize,8)+' '+mnr(ratio,2)+ + '% '+#3#5+cstr(files)+' file'; + if files<>1 then outp:=outp+'s'; + printacr(#3#4+'-------- -------- --- ------------',abort,next); + printacr(outp,abort,next); +end; + +{*------------------------------------------------------------------------*} + +function getbyte(var fp:file):char; +var buf:array[0..0] of char; + numread:word; + c:char; + abort,next:boolean; +begin + {* getbyte - Obtains character from file pointed to by fp. + * Aborts to DOS on error. + *} + + if (not aborted) then begin + blockread(fp,c,1,numread); + if numread=0 then begin + close(fp); + abend(abort,next,errmsg[1]); + end; + getbyte:=c; + end; +end; + +{*------------------------------------------------------------------------*} + +procedure zip_proc(var fp:file; var abort,next:boolean); +var zip:zipfilerec; + buf:array[0..25] of byte; + signature:longint; + numread:word; + i,stat:integer; + c:char; +begin + {* zip_proc - Process entry in ZIP archive. + *} + + while (not aborted) do begin {* set up infinite loop (exit is within loop) *} + blockread(fp,signature,4,numread); if numread<>4 then abend(abort,next,errmsg[2]); + if abort then exit; + if (signature=C_SIG) or (signature=E_SIG) or (aborted) then + exit; + if signature<>L_SIG then + abend(abort,next,errmsg[3]); + if abort then exit; + blockread(fp,zip,26,numread); if numread<>26 then abend(abort,next,errmsg[2]); + if abort then exit; + out.filename:=''; + for i:=1 to zip.f_length do {* get filename *} + out.filename[i]:=getbyte(fp); + out.filename[0]:=chr(zip.f_length); + if (zip.e_length>0) then {* skip comment if present *} + for i:=1 to zip.e_length do + c:=getbyte(fp); + out.date:=zip.mod_date; + out.time:=zip.mod_time; + out.csize:=zip.c_size; + out.usize:=zip.u_size; + case zip.method of + 0:out.typ:=2; {* Stored *} + 1:out.typ:=9; {* Shrunk *} + 2,3,4,5: + out.typ:=zip.method+8; {* Reduced *} + 6:out.typ:=15; {* Imploded *} + else + out.typ:=1; {* Unknown! *} + end; + details(abort,next); if abort then exit; + {$I-} seek(fp,filepos(fp)+zip.c_size); {$I+} {* seek to next entry *} + if (ioresult<>0) then abend(abort,next,errmsg[4]); + if (abort) then exit; + end; +end; + +{*------------------------------------------------------------------------*} + +procedure lfi(fn:astr; var abort,next:boolean); +var fp:file; + dirinfo1:searchrec; + lzh:lzhfilerec; + i1,i2,temp,infile,filename,showfn:astr; + zoo_temp,zoo_tag:longint; + numread:word; + i,p,arctype,rcode:integer; + c:char; +begin + fn:=sqoutsp(fn); + if (pos('*',fn)<>0) or (pos('?',fn)<>0) then begin + findfirst(fn,anyfile-directory-volumeid,dirinfo1); + if (doserror=0) then fn:=dirinfo1.name; + end; + if ((exist(fn)) and (not abort)) then begin + arctype:=1; + while (systat.filearcinfo[arctype].ext<>'') and + (systat.filearcinfo[arctype].ext<>copy(fn,length(fn)-2,3)) and + (arctype<7) do + inc(arctype); + if not ((systat.filearcinfo[arctype].ext='') or (arctype=7)) then begin + temp:=systat.filearcinfo[arctype].listline; + if (temp[1]='/') and (temp[2] in ['1'..'4']) and (length(temp)=2) then begin + aborted:=FALSE; + nl; +{ if (not fso) then showfn:=stripname(fn) else showfn:=fn;} + showfn:=stripname(fn); + printacr(#3#3+showfn+':',abort,next); + nl; + if (not abort) then begin + infile:=fn; + assign(fp,infile); + reset(fp,1); + + c:=getbyte(fp); {* determine type of archive *} + case c of + #$1a:filetype:=1; + 'P':begin + if getbyte(fp)<>'K' then abend(abort,next,errmsg[5]); + filetype:=2; + end; + 'Z':begin + for i:=0 to 1 do + if getbyte(fp)<>'O' then abend(abort,next,errmsg[5]); + filetype:=3; + end; + else + begin {* assume LZH format *} + lzh.h_length:=ord(c); + c:=getbyte(fp); + for i:=1 to 5 do lzh.method[i]:=getbyte(fp); + if ((lzh.method[1]='-') and + (lzh.method[2]='l') and + (lzh.method[3]='h')) then + filetype:=4 + else + abend(abort,next,errmsg[5]); + end; + end; + + reset(fp,1); {* back to start of file *} + + p:=0; {* drop drive and pathname *} + for i:=1 to length(infile) do + if infile[i] in [':','\'] then p:=i; + filename:=copy(infile,p+1,length(infile)-p); + + accum_csize:=0; accum_usize:=0; {* set accumulators to 0 *} + level:=0; files:=0; {* ditto with counters *} + + if filetype=3 then begin {* process initial ZOO file header *} + for i:=0 to 19 do {* skip header text *} + c:=getbyte(fp); + {* get tag value *} + blockread(fp,zoo_tag,4,numread); + if numread<>4 then abend(abort,next,errmsg[2]); + if zoo_tag<>Z_TAG then abend(abort,next,errmsg[5]); + {* get data start *} + blockread(fp,zoo_temp,4,numread); if numread<>4 then abend(abort,next,errmsg[2]); + {$I-} seek(fp,zoo_temp); {$I+} + if ioresult<>0 then abend(abort,next,errmsg[4]); + end; + + {* print headings *} + printacr(#3#3+' Length Size Now % Method Date Time Filename',abort,next); + printacr(#3#4+'-------- -------- --- --------- -------- ------ ------------',abort,next); + case filetype of + 1:arc_proc(fp,abort,next); {* process ARC entry *} + 2:zip_proc(fp,abort,next); {* process ZIP entry *} + 3:zoo_proc(fp,abort,next); {* process ZOO entry *} + 4:lzh_proc(fp,abort,next); {* process LZH entry *} + end; + final(abort,next); {* clean things up *} + close(fp); {* close file *} + end; + nl; + end else begin + nl; + sprompt(#3#3+'Archive '+fn+': '+#3#4+'Please wait....'); + temp:=substall(systat.filearcinfo[arctype].listline,'@F',fn); + shelldos(FALSE,temp+' >shell.$$$',rcode); + for i:=1 to 15 do prompt(^H' '^H); + nl; + pfl('shell.$$$',abort,next,TRUE); + assign(fp,'shell.$$$'); + {$I-} erase(fp); {$I+} + if (ioresult<>0) then print('Unable to show contents via external viewer.'); + end; + end; + end; +end; + +procedure lfin(rn:integer; var abort,next:boolean); +var f:ulfrec; +begin + seek(ulff,rn); read(ulff,f); + lfi(memuboard.dlpath+f.filename,abort,next); +end; + +procedure lfii; +var f:ulfrec; + fn:astr; + pl,rn:integer; + abort,next,lastarc,lastgif,isgif:boolean; +begin + nl; + sprint(fstring.viewline); +{ sprint(fstring.pninfo);} + nl; + gfn(fn); abort:=FALSE; next:=FALSE; + nl; + recno(fn,pl,rn); + if (baddlpath) then exit; + abort:=FALSE; next:=FALSE; lastarc:=fALSE; lastgif:=FALSE; + while ((rn<>0) and (not abort)) do begin + seek(ulff,rn); read(ulff,f); + isgif:=isgifext(f.filename); + if (isgif) then begin + lastarc:=FALSE; + if (not lastgif) then begin + lastgif:=TRUE; + nl; nl; + printacr(#3#3+'Filename.Ext '+sepr2+' Resolution '+sepr2+ + ' Num Colors '+sepr2+' Signat.',abort,next); + printacr(#3#4+'=============:============:============:=========',abort,next); + end; + dogifspecs(sqoutsp(memuboard.dlpath+f.filename),abort,next); + end else begin + lastgif:=FALSE; + if (not lastarc) then begin + lastarc:=TRUE; + nl; +(* nl; nl; + printacr(#3#5+'IFL v1.30 '+#3#1+'-'+#3#3+' By Martin Pollard '+ + #3#1+'--',abort,next);*) + end; + lfin(rn,abort,next); + end; + nrecno(fn,pl,rn); + if (next) then abort:=FALSE; + next:=FALSE; + end; + close(ulff); +end; + +end. diff --git a/file5.pas b/file5.pas new file mode 100644 index 0000000..ac7f7ec --- /dev/null +++ b/file5.pas @@ -0,0 +1,770 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file5; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, + sysop4, + file0, file1, file2, file4, file8, file9, file11, + execbat; + +procedure minidos; +procedure browse; +procedure uploadall; + +implementation + +uses archive1; + +var + xword:array[1..9] of astr; + +procedure parse(s:astr); +var i,j,k:integer; +begin + for i:=1 to 9 do xword[i]:=''; + i:=1; j:=1; k:=1; + if (length(s)=1) then xword[1]:=s; + while (i0) or (pos('..',xword[2])<>0)) and + (restr) then exit; + + if (s='DIR/W') then s:='DIR *.* /W'; + if (s='?') or (s='HELP') then printf('minidos') + else + if (s='EDIT') or (s='EDLIN') then begin + if ((exist(xword[2])) and (xword[2]<>'')) then tedit(xword[2]) + else + if (xword[2]='') then tedit1 else tedit(xword[2]); + end + else + if (s='EXIT') or (s='QUIT') then done:=TRUE + else + if ((s='DEL') or (s='DELETE')) and (not restr1) then begin + if ((not exist(xword[2])) and (not iswildcard(xword[2]))) or + (xword[2]='') then + print('File not found.') + else begin + xword[2]:=fexpand(xword[2]); + ffile(xword[2]); + repeat + if not ((dirinfo.attr and VolumeID=VolumeID) or + (dirinfo.attr and Directory=Directory)) then begin + assign(f,dirinfo.name); + {$I-} erase(f); {$I+} + if (ioresult<>0) then + print('"'+dirinfo.name+'": Could not delete!'); + end; + nfile; + until (not found) or (hangup); + end; + end + else + if (s='TYPE') then begin + printf(fexpand(xword[2])); + if (nofile) then print('File not found.'); + end + else + if ((s='REN') or (s='RENAME')) then begin + if ((not exist(xword[2])) and (xword[2]<>'')) then + print('File not found.') + else begin + xword[2]:=fexpand(xword[2]); + assign(f,xword[2]); + {$I-} rename(f,xword[3]); {$I+} + if (ioresult<>0) then print('File not found.'); + end + end + else + if (s='DIR') then begin + b:=TRUE; + for i:=2 to 9 do if (xword[i]='/W') then begin + b:=FALSE; + xword[i]:=''; + end; + if (xword[2]='') then xword[2]:='*.*'; + s1:=curdir; + xword[2]:=fexpand(xword[2]); + fsplit(xword[2],ps,ns,es); + s1:=ps; s2:=ns+es; + if (s2='') then s2:='*.*'; + if (not iswildcard(xword[2])) then begin + ffile(xword[2]); + if ((found) and (dirinfo.attr=directory)) or + ((length(s1)=3) and (s1[3]='\')) then begin {* root directory *} + s1:=bslash(TRUE,xword[2]); + s2:='*.*'; + end; + end; + nl; dir(s1,s2,b); nl; + end + else + if ((s='CD') or (s='CHDIR')) and (xword[2]<>'') and (not restr1) then begin + xword[2]:=fexpand(xword[2]); + {$I-} chdir(xword[2]); {$I+} + if (ioresult<>0) then print('Invalid pathname.'); + end + else + if ((s='MD') or (s='MKDIR')) and (xword[2]<>'') and (not restr1) then begin + {$I-} mkdir(xword[2]); {$I+} + if (ioresult<>0) then print('Unable to create directory.'); + end + else + if ((s='RD') or (s='RMDIR')) and (xword[2]<>'') and (not restr1) then begin + {$I-} rmdir(xword[2]); {$I+} + if (ioresult<>0) then print('Unable to remove directory.'); + end + else + if (s='COPY') and (not restr1) then begin + if (xword[2]<>'') then begin + if (iswildcard(xword[3])) then + print('Wildcards not allowed in destination parameter!') + else begin + if (xword[3]='') then xword[3]:=curdir; + xword[2]:=bslash(FALSE,fexpand(xword[2])); + xword[3]:=fexpand(xword[3]); + ffile(xword[3]); + b:=((found) and (dirinfo.attr and directory=directory)); + if ((not b) and (copy(xword[3],2,2)=':\') and + (length(xword[3])=3)) then b:=TRUE; + + fsplit(xword[2],op,ns,es); + op:=bslash(TRUE,op); + + if (b) then + np:=bslash(TRUE,xword[3]) + else begin + fsplit(xword[3],np,ns,es); + np:=bslash(TRUE,np); + end; + + j:=0; + abort:=FALSE; next:=FALSE; + ffile(xword[2]); + while (found) and (not abort) and (not hangup) do begin + if (not ((dirinfo.attr=directory) or (dirinfo.attr=volumeid))) then + begin + s1:=op+dirinfo.name; + if (b) then s2:=np+dirinfo.name else s2:=np+ns+es; + prompt(s1+' -> '+s2+' :'); + copyfile(ok,nospace,TRUE,s1,s2); + if (ok) then begin + inc(j); + nl; + end else + if (nospace) then sprompt(#3#7+' - *Insufficient space*') + else sprompt(#3#7+' - *Copy failed*'); + nl; + end; + if (not empty) then wkey(abort,next); + nfile; + end; + if (j<>0) then begin + prompt(' '+cstr(j)+' file'); + if (j<>1) then prompt('s'); + print(' copied.'); + end; + end; + end; + end + else + if (s='MOVE') and (not restr1) then begin + if (xword[2]<>'') then begin + if (iswildcard(xword[3])) then + print('Wildcards not allowed in destination parameter!') + else begin + if (xword[3]='') then xword[3]:=curdir; + xword[2]:=bslash(FALSE,fexpand(xword[2])); + xword[3]:=fexpand(xword[3]); + ffile(xword[3]); + b:=((found) and (dirinfo.attr and directory=directory)); + if ((not b) and (copy(xword[3],2,2)=':\') and + (length(xword[3])=3)) then b:=TRUE; + + fsplit(xword[2],op,ns,es); + op:=bslash(TRUE,op); + + if (b) then + np:=bslash(TRUE,xword[3]) + else begin + fsplit(xword[3],np,ns,es); + np:=bslash(TRUE,np); + end; + + j:=0; + abort:=FALSE; next:=FALSE; + ffile(xword[2]); + while (found) and (not abort) and (not hangup) do begin + if (not ((dirinfo.attr=directory) or (dirinfo.attr=volumeid))) then + begin + s1:=op+dirinfo.name; + if (b) then s2:=np+dirinfo.name else s2:=np+ns+es; + prompt(s1+' -> '+s2+' :'); + movefile(ok,nospace,TRUE,s1,s2); + if (ok) then begin + inc(j); + nl; + end else + if (nospace) then sprompt(#3#7+' - *Insufficient space*') + else sprompt(#3#7+' - *Move failed*'); + nl; + end; + if (not empty) then wkey(abort,next); + nfile; + end; + if (j<>0) then begin + prompt(' '+cstr(j)+' file'); + if (j<>1) then prompt('s'); + print(' moved.'); + end; + end; + end; + end + else + if (s='CLS') then cls + else + if (length(s)=2) and (s[1]>='A') and (s[1]<='Z') and + (s[2]=':') and (not restr1) then begin + {$I-} getdir(ord(s[1])-64,s1); {$I+} + if (ioresult<>0) then print('Invalid drive.') + else begin + {$I-} chdir(s1); {$I+} + if (ioresult<>0) then begin + print('Invalid drive.'); + chdir(curdir); + end; + end; + end + else + if (s='IFL') then begin + if (xword[2]='') then begin +(* + nl; + print('IFL v1.30 - May 09 1989 - Interior File Listing Utility'); + print('Copyright 1989 by Martin Pollard. All rights reserved!'); + print('Licensed for internal usage in Telegard v'+ver); +*) + nl; + print('Syntax is: "IFL filename"'); + nl; +(* + print('IFL produces a listing of files contained in an archive file.'); + print('Archive formats currently supported include:'); + nl; + print(' ARC - Developed by System Enhancement Associates'); + print(' and enhanced by PKware (PKARC & PKPAK)'); + print(' and NoGate Consulting (PAK)'); + print(' LZH - Developed by Haruyasu Yoshizaki'); + print(' ZIP - Developed by PKware'); + print(' ZOO - Developed by Rahul Dhesi'); + nl; + print('Support for other formats may be included in the future.'); + nl; +*) + end else begin + s1:=xword[2]; + if (pos('.',s1)=0) then s1:=s1+'*.*'; + lfi(s1,abort,next); + end; + end + else + if (s='SEND') and (xword[2]<>'') then begin + if exist(xword[2]) then unlisted_download(fexpand(xword[2])) + else print('File not found.'); + end + else + if (s='VER') then versioninfo + else + if (s='FORMAT') then begin + nl; + print('HA HA HA - Very funny - You must be dumber than you look.'); + nl; + end else + if (s='DIRSIZE') then begin + nl; + if (xword[2]='') then print('Needs a parameter.') + else begin + numfiles:=0; tsiz:=0; + ffile(xword[2]); + while (found) do begin + inc(tsiz,dirinfo.size); + inc(numfiles); + nfile; + end; + if (numfiles=0) then print('No files found!') + else print('"'+allcaps(xword[2])+'": '+cstrl(numfiles)+' files, '+ + cstrl(tsiz)+' bytes.'); + end; + nl; + end + else + if (s='DISKFREE') then begin + if (xword[2]='') then j:=exdrv(curdir) else j:=exdrv(xword[2]); + nl; + print(cstrl(freek(j)*1024)+' bytes free on '+chr(j+64)+':'); + nl; + end + else + if (s='EXT') and (not restr1) then begin + s1:=cmd; + j:=pos('EXT',allcaps(s1))+3; s1:=copy(s1,j,length(s1)-(j-1)); + while (copy(s1,1,1)=' ') do s1:=copy(s1,2,length(s1)-1); + if ((incom) or (outcom)) then + s1:=s1+' >'+systat.remdevice+' <'+systat.remdevice; + if (length(s1)>127) then begin nl; print('Command too long!'); nl; end + else + shelldos(TRUE,s1,retlevel); + end + else + if ((s='CONVERT') or (s='CVT')) and (not restr1) then begin + if (xword[2]='') then begin + nl; + print(s+' - Telegard archive conversion command.'); + nl; + print('Syntax is: "'+s+' "'); + nl; + print('Telegard will convert from the one archive format to the other.'); + print('You only need to specify the 3-letter extension of the new format.'); + nl; + end else begin + if (not exist(xword[2])) or (xword[2]='') then print('File not found.') + else begin + i:=arctype(xword[2]); + if (i=0) then invarc + else begin + s3:=xword[3]; s3:=copy(s3,length(s3)-2,3); + j:=arctype('FILENAME.'+s3); + fsplit(xword[2],ps,ns,es); + if (length(xword[3])<=3) and (j<>0) then + s3:=ps+ns+'.'+systat.filearcinfo[j].ext + else + s3:=xword[3]; + if (j=0) then invarc + else begin + ok:=TRUE; + conva(ok,i,j,systat.temppath+'1\',sqoutsp(fexpand(xword[2])), + sqoutsp(fexpand(s3))); + if (ok) then begin + assign(fi,sqoutsp(fexpand(xword[2]))); + {$I-} erase(fi); {$I+} + if (ioresult<>0) then + star('Unable to delete original: "'+ + sqoutsp(fexpand(xword[2]))+'"'); + end else + star('Conversion unsuccessful.'); + end; + end; + end; + end; + end else + if ((s='UNARC') or (s='UNZIP') or + (s='PKXARC') or (s='PKUNPAK') or (s='PKUNZIP')) and (not restr1) then begin + if (xword[2]='') then begin + nl; + print(s+' - Telegard archive de-compression command.'); + nl; + print('Syntax is: "'+s+' Archive filespecs..."'); + nl; + print('The archive type can be ANY archive format which has been'); + print('configured into Telegard via System Configuration.'); + nl; + end else begin + i:=arctype(xword[2]); + if (not exist(xword[2])) then print('File not found.') else + if (i=0) then invarc + else begin + s3:=''; + if (xword[3]='') then s3:=' *.*' + else + for j:=3 to 9 do + if (xword[j]<>'') then s3:=s3+' '+fexpand(xword[j]); + s3:=copy(s3,2,length(s3)-1); + shel1; + pexecbatch(TRUE,'tgtemp1.bat','',bslash(TRUE,curdir), + arcmci(systat.filearcinfo[i].unarcline,fexpand(xword[2]),s3), + retlevel); + shel2; + end; + end; + end + else + if ((s='ARC') or (s='ZIP') or + (s='PKARC') or (s='PKPAK') or (s='PKZIP')) and (not restr1) then begin + if (xword[2]='') then begin + nl; + print(s+' - Telegard archive compression command.'); + nl; + print('Syntax is: "'+s+' Archive filespecs..."'); + nl; + print('The archive type can be ANY archive format which has been'); + print('configured into Telegard via System Configuration.'); + nl; + end else begin + i:=arctype(xword[2]); + if (i=0) then invarc + else begin + s3:=''; + if (xword[3]='') then s3:=' *.*' + else + for j:=3 to 9 do + if (xword[j]<>'') then s3:=s3+' '+fexpand(xword[j]); + s3:=copy(s3,2,length(s3)-1); + shel1; + pexecbatch(TRUE,'tgtemp1.bat','',bslash(TRUE,curdir), + arcmci(systat.filearcinfo[i].arcline,fexpand(xword[2]),s3), + retlevel); + shel2; + end; + end; + end else begin + nocmd:=TRUE; + if (s<>'') then + if (not wasrestr) then print('Bad command or file name') + else print('Restricted command.'); + end; + end; + +begin + chdir(bslash(FALSE,systat.afilepath)); + restr:=(not cso); + done:=FALSE; + nl; + print('Type "EXIT" to return to Telegard.'); + nl; + versioninfo; + if (restr) then begin + print('Only *.MSG, *.ANS, *.40C and *.TXT files may be modified.'); + print('Activity restricted to "'+systat.afilepath+'" path only.'); + nl; + end; + repeat + getdir(0,curdir); + prompt('<'+curdir+'> '); inputl(s1,128); parse(s1); + docmd(s1); + if (not nocmd) then sysoplog('> '+s1); + until (done) or (hangup); + chdir(start_dir); +end; + +procedure browse; +const perpage=15; +var f:ulfrec; + filenum:array[1..20] of integer; + s:astr; + i,a1,a2,numadd,pl,topp,otopp,savflistopt:integer; + c:char; + abort,next,done,done1,showlist:boolean; + + procedure listpage; + begin + abort:=FALSE; next:=FALSE; + if (topp>pl) then topp:=otopp; + otopp:=topp; + bnp:=FALSE; + while (topp-otopppl)) then exit; + + done:=FALSE; showlist:=TRUE; otopp:=topp; + savflistopt:=thisuser.flistopt; thisuser.flistopt:=30; + repeat + if (showlist) then listpage; + showlist:=FALSE; abort:=FALSE; next:=FALSE; + nl; + prt(#3#5+'['+cstr(topp)+']'+#3#4+' Browse files (1-'+cstr(pl)+',?=help) : '); + input(s,4); + if ((value(s)>=1) and (value(s)<=pl)) then begin + nl; + seek(ulff,value(s)); read(ulff,f); + fileinfo(f,FALSE,abort,next); + s:='xxxx'; + end; + if (length(s)>=1) then c:=s[1] else c:=^M; + i:=value(copy(s,2,length(s)-1)); + case c of + '?':begin + nl; + print('###:File description'); + lcmds(9,3,'Download','-Back up a page'); + lcmds(9,3,'Jump','List or for next page'); + lcmds(9,3,'Upload','Numbered download'); + lcmds(9,3,'Quit','View interior'); + end; + 'L',^M:showlist:=TRUE; {* do nothing *} + 'B','-':begin + dec(topp,perpage*2); + if (topp<1) then topp:=1; + showlist:=TRUE; + end; + 'D':if ((i>=1) and (i<=pl)) then begin + seek(ulff,i); read(ulff,f); + abort:=FALSE; + dlx(f,i,abort); + end else begin + idl; + fiscan(pl); + end; + 'J':begin + if ((i<1) or (i>pl)) then begin + i:=0; + nl; prt('Goto which file? (1-'+cstr(pl)+') : '); inu(i); + if (badini) then i:=0; + end; + if (i>=1) and (i<=pl) then topp:=i; + showlist:=TRUE; + end; + 'N':begin + if (i>=1) and (i<=pl) then begin + filenum[1]:=i; + numadd:=1; + end else begin + nl; + print('Numbered download.'); + print('Enter single file number, or multiple file numbers'); + print('seperated by commas, max 20.'); + prt(':'); input(s,78); + done1:=FALSE; numadd:=0; + if (s<>'') then + repeat + if ((value(s)>=1) and (value(s)<=filesize(ulff)-1)) then begin + inc(numadd); filenum[numadd]:=value(s); + end; + if (pos(',',s)=0) then done1:=TRUE + else s:=copy(s,pos(',',s)+1,length(s)-pos(',',s)); + until (done1) or (numadd=20); + end; + done1:=FALSE; + if (numadd=1) then begin + seek(ulff,filenum[1]); read(ulff,f); + nl; + if (okdl(f)) then + if (pynq('Download immediately? ')) then begin + seek(ulff,filenum[1]); read(ulff,f); + abort:=FALSE; + dlx(f,filenum[1],abort); + done1:=TRUE; + end; + end; + if (not done1) then begin + nl; + print('File list:'); + for i:=1 to numadd do begin + seek(ulff,filenum[i]); read(ulff,f); + print(' '+sqoutsp(f.filename)); + end; + nl; + if pynq('Add these files to your batch queue? ') then begin + a2:=0; + for i:=1 to numadd do begin + seek(ulff,filenum[i]); read(ulff,f); + a1:=numbatchfiles; + if (okdl(f)) then ymbadd(memuboard.dlpath+f.filename); + if (numbatchfiles<>a1) then inc(a2); + end; + nl; + print(cstr(a2)+' files added to batch queue.'); + end; + end; + end; + 'U':begin + iul; + fiscan(pl); + end; + 'V':begin + if (i>=1) and (i<=pl) then begin + abort:=FALSE; next:=FALSE; + lfin(i,abort,next); + end + else lfii; + fiscan(pl); + end; + 'Q':done:=TRUE; + end; + until (done) or (hangup); + close(ulff); + thisuser.flistopt:=savflistopt; +end; + +procedure uploadall; +var bn,savflistopt:integer; + abort,next,sall:boolean; + + procedure uploadfiles(b:integer; var abort,next:boolean); + var fi:file of byte; + f:ulfrec; + v:verbrec; + fn:astr; + convtime:real; + oldboard,pl,rn,gotpts,i:integer; + c:char; + ok,convt,firstone:boolean; + begin + oldboard:=fileboard; + firstone:=TRUE; + if (fileboard<>b) then changefileboard(b); + if (fileboard=b) then begin + loaduboard(fileboard); + nl; + sprint('Scanning '+#3#5+memuboard.name+#3#1+' ('+memuboard.dlpath+')'); + ffile(memuboard.dlpath+'*.*'); + while (found) do begin + if not ((dirinfo.attr and VolumeID=VolumeID) or + (dirinfo.attr and Directory=Directory)) then begin + fn:=align(dirinfo.name); + recno(fn,pl,rn); { loads memuboard again .. } + if (rn=0) then begin + assign(fi,memuboard.dlpath+fn); + {$I-} reset(fi); {$I+} + if (ioresult=0) then begin + f.blocks:=trunc((filesize(fi)+127.0)/128.0); + close(fi); + if (firstone) then pbn(abort,next); + firstone:=FALSE; + sprompt(' '+#3#3+fn+' '+#3#4+mln(cstr(f.blocks div 8),3)+' New:'); + cl(5); inputl(f.description,60); + ok:=TRUE; + if (copy(f.description,1,1)='.') then begin + if (length(f.description)=1) then begin + abort:=TRUE; + exit; + end; + c:=upcase(f.description[2]); + case c of + 'D':begin + {$I-} erase(fi); {$I+} i:=ioresult; + ok:=FALSE; + end; + 'N':begin + next:=TRUE; + exit; + end; + 'S':ok:=FALSE; + end; + end; + if (ok) then begin + v.descr[1]:=''; + if (copy(f.description,1,1)='\') then begin + f.description:=copy(f.description,2,length(f.description)-1); + nl; + print('You may use up to four lines of 50 characters each.'); + print('Enter a blank line to end.'); + nl; + i:=1; + repeat + prt(cstr(i)+':'); + mpl(50); + inputl(v.descr[i],50); + if (v.descr[i]='') then i:=4; + inc(i); + until ((i=5) or (hangup)); + if (v.descr[1]<>'') then f.vpointer:=nfvpointer + else begin + nl; print('No verbose description saved.'); + end; + nl; + end; + if (v.descr[1]='') then f.vpointer:=-1; +(* arcstuff(ok,convt,f.blocks,convtime,FALSE,uboards[fileboard]^.dlpath,fn);*) + doffstuff(f,fn,gotpts); + if (ok) then begin + newff(f,v); + sysoplog(#3#3+'Upload "'+sqoutsp(fn)+'" on '+memuboard.name); + end; + end; + end; + end; + end; + nfile; + end; + end; + fileboard:=oldboard; + end; + +begin + savflistopt:=thisuser.flistopt; thisuser.flistopt:=1; + nl; print('Upload files into directories -'); nl; + abort:=FALSE; next:=FALSE; + sall:=pynq('Search all directories? '); + nl; + print('Enter a single "\" in front of description to enter a verbose'); + print('description too. Enter "." to stop uploading, ".S" to skip this file,'); + print('".N" to skip to the next directory, and ".D" to delete this file.'); + if (sall) then begin + bn:=0; + while (not abort) and (bn<=maxulb) and (not hangup) do begin + if (fbaseac(bn)) then uploadfiles(bn,abort,next); + inc(bn); + wkey(abort,next); + if (next) then abort:=FALSE; + end; + end else + uploadfiles(fileboard,abort,next); + thisuser.flistopt:=savflistopt; +end; + +end. diff --git a/file6.pas b/file6.pas new file mode 100644 index 0000000..5b42551 --- /dev/null +++ b/file6.pas @@ -0,0 +1,557 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file6; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + file0, file1, file2, file4, file9, + execbat, + common; + +procedure delbatch(n:integer); +procedure mpkey(var s:astr); +function bproline1(cline:astr):astr; +procedure bproline(var cline:astr; filespec:astr); +function okprot(prot:protrec; ul,dl,batch,resume:boolean):boolean; +procedure showprots(ul,dl,batch,resume:boolean); +function findprot(cs:astr; ul,dl,batch,resume:boolean):integer; +procedure batchdl; +procedure listbatchfiles; +procedure removebatchfiles; +procedure clearbatch; + +implementation + +procedure delbatch(n:integer); +var c:integer; +begin + if ((n>=1) and (n<=numbatchfiles)) then begin + batchtime:=batchtime-batch[n].tt; + if (n<>numbatchfiles) then + for c:=n to numbatchfiles-1 do batch[c]:=batch[c+1]; + dec(numbatchfiles); + end; +end; + +procedure mpkey(var s:astr); +var sfqarea,smqarea:boolean; +begin + sfqarea:=fqarea; smqarea:=mqarea; + fqarea:=FALSE; mqarea:=FALSE; + + mmkey(s); + + fqarea:=sfqarea; mqarea:=smqarea; +end; + +function bproline2(cline:astr):astr; +var s:astr; +begin + s:=substall(cline,'%C',start_dir); + s:=substall(s,'%G',copy(systat.gfilepath,1,length(systat.gfilepath)-1)); + bproline2:=s; +end; + +function bproline1(cline:astr):astr; +var s,s1:astr; +begin + if ((not incom) and (not outcom)) then s1:=cstrl(modemr.waitbaud) else s1:=spd; + s:=substall(cline,'%B',s1); + s:=substall(s,'%L',bproline2(protocol.dlflist)); + s:=substall(s,'%P',cstr(modemr.comport)); + s:=substall(s,'%T',bproline2(protocol.templog)); + bproline1:=bproline2(s); +end; + +procedure bproline(var cline:astr; filespec:astr); +const lastpos:integer=-1; +begin + if (pos('%F',cline)<>0) then begin + lastpos:=pos('%F',cline)+length(filespec); + cline:=substall(cline,'%F',filespec); + end else begin + insert(' '+filespec,cline,lastpos); + inc(lastpos,length(filespec)+1); + end; +end; + +function okprot(prot:protrec; ul,dl,batch,resume:boolean):boolean; +var s:astr; +begin + okprot:=FALSE; + with prot do begin + if (ul) then s:=ulcmd else if (dl) then s:=dlcmd else s:=''; + if (s='NEXT') and ((ul) or (batch) or (resume)) then exit; + if (s='BATCH') and ((batch) or (resume)) then exit; + if (batch<>(xbisbatch in xbstat)) then exit; + if (resume<>(xbisresume in xbstat)) then exit; + if (not (xbactive in xbstat)) then exit; + if (not aacs(acs)) then exit; + if (s='') then exit; + end; + okprot:=TRUE; +end; + +procedure showprots(ul,dl,batch,resume:boolean); +var s:astr; + i:integer; + abort,next:boolean; +begin + nofile:=TRUE; + if (resume) then printf('protres') + else begin + if (batch) and (ul) then printf('protbul'); + if (batch) and (dl) then printf('protbdl'); + if (not batch) and (ul) then printf('protsul'); + if (not batch) and (dl) then printf('protsdl'); + end; + if (nofile) then begin + seek(xf,0); + abort:=FALSE; next:=FALSE; i:=0; + while ((i<=filesize(xf)-1) and (not abort)) do begin + read(xf,protocol); + if (okprot(protocol,ul,dl,batch,resume)) then sprint(protocol.descr); + if (not empty) then wkey(abort,next); + inc(i); + end; + end; +end; + +(* XF should be OPEN -- + returns: + (-1):Ascii (xx):Xmodem (xx):Xmodem-CRC (xx):Ymodem + (-10):Quit (-11):Next (-12):Batch (-99):Invalid (or no access) + else, the protocol # +*) +function findprot(cs:astr; ul,dl,batch,resume:boolean):integer; +var s:astr; + i:integer; + done:boolean; +begin + findprot:=-99; + if (cs='') then exit; + seek(xf,0); + done:=FALSE; i:=0; + while ((i<=filesize(xf)-1) and (not done)) do begin + read(xf,protocol); + with protocol do + if (cs=ckeys) then + if (okprot(protocol,ul,dl,batch,resume)) then begin + if (ul) then s:=ulcmd else if (dl) then s:=dlcmd else s:=''; + if (s='ASCII') then begin done:=TRUE; findprot:=-1; end + else if (s='QUIT') then begin done:=TRUE; findprot:=-10; end + else if (s='NEXT') then begin done:=TRUE; findprot:=-11; end + else if (s='BATCH') then begin done:=TRUE; findprot:=-12; end + else if (s<>'') then begin done:=TRUE; findprot:=i; end; + end; + inc(i); + end; +end; + +procedure batchdl; +var batfile,tfil:text; {@4 file list file} + xferstart,xferend,tooktime,batchtime1:datetimerec; + nfn,snfn,s,s1,s2,i,logfile:astr; + st,tott,tooktime1:real; + tblks,tblks1,cps,lng:longint; + tpts,tpts1,tnfils,tnfils1:integer; + sx,sy,hua,n,p,toxfer,rcode:integer; + c:char; + swap,done1,dok,kabort,nomore,readlog:boolean; + + function tempfile(i:integer):astr; + begin + tempfile:='temp'+cstr(i)+'.$$$'; + end; + + procedure sprtcl(c:char; s:astr); + var wnl:boolean; + begin + if copy(s,length(s),1)<>#0 then wnl:=TRUE else wnl:=FALSE; + if not wnl then s:=copy(s,1,length(s)-1); + sprompt('^3'+c+'^1) ^4'+s); + if wnl then nl; + end; + + procedure addnacc(i:integer; s:astr); + var f:ulfrec; + oldboard,pl,rn:integer; + begin + if (i<>-1) then begin + oldboard:=fileboard; fileboard:=i; + s:=sqoutsp(stripname(s)); + recno(s,pl,rn); {* opens ulff *} + if rn<>0 then begin + seek(ulff,rn); read(ulff,f); + inc(f.nacc); + seek(ulff,rn); write(ulff,f); + end; + fileboard:=oldboard; + close(ulff); + end; + end; + + procedure chopoffspace(var s:astr); + begin + if (pos(' ',s)<>0) then s:=copy(s,1,pos(' ',s)-1); + end; + + procedure figuresucc; + var filestr,statstr:astr; + foundit:boolean; + + function wasok:boolean; + var i:integer; + foundcode:boolean; + begin + foundcode:=FALSE; + for i:=1 to 6 do + if (protocol.dlcode[i]<>'') and + (protocol.dlcode[i]=copy(statstr,1,length(protocol.dlcode[i]))) then + foundcode:=TRUE; + wasok:=FALSE; + if ((foundcode) and (not (xbxferokcode in protocol.xbstat))) then exit; + if ((not foundcode) and (xbxferokcode in protocol.xbstat)) then exit; + wasok:=TRUE; + end; + + begin + readlog:=FALSE; + if (protocol.templog<>'') then begin + assign(batfile,bproline1(protocol.templog)); + {$I-} reset(batfile); {$I+} + if (ioresult=0) then begin + assign(tfil,bproline1(protocol.dloadlog)); + {$I-} append(tfil); {$I+} + if (ioresult<>0) then rewrite(tfil); + readlog:=TRUE; + while (not eof(batfile)) do begin + readln(batfile,s); writeln(tfil,s); + filestr:=copy(s,protocol.logpf,length(s)-(protocol.logpf-1)); + statstr:=copy(s,protocol.logps,length(s)-(protocol.logps-1)); + chopoffspace(filestr); + foundit:=FALSE; n:=0; + while ((n0) do begin + sysoplog(#3#5+'Batch download "'+stripname(batch[1].fn)+'"'); + inc(tnfils); + inc(tblks,batch[1].blks); + inc(tpts,batch[1].pts); + loaduboard(batch[1].section); + if (not (fbnoratio in memuboard.fbstat)) then begin + inc(tnfils1); + inc(tblks,batch[1].blks); + inc(tpts1,batch[1].pts); + end; + addnacc(batch[1].section,batch[1].fn); + delbatch(1); dec(toxfer); + end; + end; + end; + +begin + if (numbatchfiles=0) then begin + nl; print('Batch queue empty.'); + end else begin + nl; + print('Checking batch download request...'); + + tott:=0.0; + for n:=1 to numbatchfiles do + tott:=tott+batch[n].tt; + + nl; + print('Number files in batch .. : '+cstr(numbatchfiles)); + print('Batch download time .... : '+ctim(tott)); + print('Time left online ....... : '+ctim(nsl)); + + if (tott>nsl) then begin + nl; + print('Insufficient time for download!!'); + print('You must remove some files from your batch queue.'); + exit; + end; + + reset(xf); + done1:=FALSE; + repeat + nl; + sprompt('^4Batch Protocol (^0?^4=^0list^4) : ^3'); mpkey(i); + if (i='?') then begin + nl; + showprots(FALSE,TRUE,TRUE,FALSE); + end else begin + p:=findprot(i,FALSE,TRUE,TRUE,FALSE); + if (p=-99) then print('Invalid entry.') else done1:=TRUE; + end; + until (done1) or (hangup); + if (p<>-10) then begin + seek(xf,p); read(xf,protocol); close(xf); + nl; sprint(#3#7+'Hangup after transfer?'); + prt('(A)bort (N)o (Y)es (M)aybe : '); onek(c,'ANYM'^M); + if (c=^M) then c:='N'; + hua:=pos(c,'ANYM'); + dok:=TRUE; + if (hua<>1) then begin + tblks:=0; tpts:=0; tnfils:=0; + tblks1:=0; tpts1:=0; tnfils1:=0; + nl; nl; + + nfn:=bproline1(protocol.dlcmd); + toxfer:=0; tott:=0.0; + if (pos('%F',protocol.dlcmd)<>0) then begin + done1:=FALSE; + while ((not done1) and (toxferprotocol.maxchrs) then done1:=TRUE + else tott:=tott+batch[toxfer].tt; + end; + end; + + if (protocol.dlflist<>'') then begin + tott:=0.0; + assign(batfile,bproline1(protocol.dlflist)); + rewrite(batfile); + for n:=1 to numbatchfiles do begin + writeln(batfile,batch[n].fn); + inc(toxfer); tott:=tott+batch[n].tt; + end; + close(batfile); + end; + + (* output x-fer batch file *) + assign(batfile,'tgtemp1.bat'); rewrite(batfile); + if (protocol.envcmd<>'') then + writeln(batfile,bproline1(protocol.envcmd)); + writeln(batfile,nfn); + writeln(batfile,'exit'); + close(batfile); + + (* delete old log file *) + if (exist(bproline1(protocol.templog))) then begin + assign(batfile,bproline1(protocol.templog)); + {$I-} erase(batfile); {$I+} + end; + + r2dt(batchtime,batchtime1); + if (useron) then + print('Transmitting batch - Time: '+longtim(batchtime1)); + + if (useron) then shel(caps(thisuser.name)+' is batch downloading!') + else shel('Sending file(s)...'); + + getdatetime(xferstart); + swap:=systat.swapshell; + systat.swapshell:=FALSE; + shelldos(FALSE,'tgtemp1',rcode); + systat.swapshell:=swap; + shel2; + getdatetime(xferend); + timediff(tooktime,xferstart,xferend); + + (* delete TGTEMP1.BAT batch file *) + assign(batfile,'tgtemp1.bat'); + {$I-} erase(batfile); {$I+} + + figuresucc; + + tooktime1:=dt2r(tooktime); + if (tooktime1>=1.0) then begin + cps:=tblks; cps:=cps*128; + cps:=trunc(cps/tooktime1); + end else + cps:=0; + + showuserfileinfo; + commandline(''); + nl; nl; + + s:='Download totals: '; + if (tnfils=0) then s:=s+'No' else s:=s+cstr(tnfils); + s:=s+' file'; if (tnfils<>1) then s:=s+'s'; + lng:=tblks; lng:=lng*128; + s:=s+', '+cstrl(lng)+' bytes'; + if (tpts<>0) then begin + s:=s+', '+cstr(tpts)+' file point'; + if (tpts<>1) then s:=s+'s'; + end; + s:=s+'.'; + star(s); + + if (tnfils1<>tnfils) then begin + if (tnfils1) then s:=s+'s'; + lng:=tblks1; lng:=lng*128; + s:=s+', '+cstrl(lng)+' bytes'; + if (tpts1<>0) then begin + s:=s+', '+cstr(tpts1)+' file point'; + if (tpts1<>1) then s:=s+'s'; + end; + s:=s+'.'; + star(s); + end; + + star('Download time: '+longtim(tooktime)); + star('Transfer rate: '+cstr(cps)+' cps'); + + thisuser.dk:=thisuser.dk+(tblks1 div 8); + inc(thisuser.downloads,tnfils1); + dec(thisuser.filepoints,tpts1); + + inc(systat.todayzlog.downloads,tnfils); + inc(systat.todayzlog.dk,tblks div 8); + + if (numbatchfiles<>0) then begin + tblks:=0; tpts:=0; + for n:=1 to numbatchfiles do begin + inc(tblks,batch[n].blks); + inc(tpts,batch[n].pts); + end; + lng:=tblks; lng:=lng*128; + s:='Not transferred: '+cstr(numbatchfiles)+' file'; + if (numbatchfiles<>1) then s:=s+'s'; + s:=s+', '+cstrl(lng)+' bytes'; + if (tpts<>0) then begin + s:=s+', '+cstr(tpts)+' file point'; + if (tpts<>1) then s:=s+'s'; + end; + s:=s+'.'; + star(s); + end; + + case hua of + 3:hangup:=TRUE; + 4:begin + nl; + nl; + print('System will automatically hang up in 30 seconds.'); + print('Hit [H] to hang up now, any other key to abort.'); + st:=timer; + while (tcheck(st,30)) and (empty) do; + if (empty) then hangup:=TRUE; + if (not empty) then + if upcase(inkey)='H' then + hangup:=TRUE; + end; + end; + end; + end; + end; +end; + +procedure listbatchfiles; +var tot:record + pts:integer; + blks:longint; + tt:real; + end; + s:astr; + i:integer; + abort,next:boolean; +begin + if (numbatchfiles=0) then begin + nl; print('Batch queue empty.'); + end else begin + abort:=FALSE; next:=FALSE; + with tot do begin + pts:=0; blks:=0; tt:=0.0; + end; + + nl; + printacr(#3#4+'##:Filename.Ext Area Pts Bytes hh:mm:ss',abort,next); + printacr(#3#4+'--------------- ---- ----- ------- --------',abort,next); + + i:=1; + while (not abort) and (not hangup) and (i<=numbatchfiles) do begin + with batch[i] do begin + if section=-1 then s:=#3#7+'Unli' else s:=#3#5+mrn(cstr(section),4); + s:=#3#3+mn(i,2)+#3#4+':'+#3#5+align(stripname(fn))+' '+ + s+' '+#3#4+mrn(cstr(pts),5)+' '+ + #3#4+mrn(cstrl(blks*128),7)+' '+#3#7+ctim(tt); + if (section<>-1) then begin + loaduboard(section); + if (fbnoratio in memuboard.fbstat) then s:=s+#3#5+' '; + end; + printacr(s,abort,next); + tot.pts:=tot.pts+pts; + tot.blks:=tot.blks+blks; + tot.tt:=tot.tt+tt; + end; + inc(i); + end; + + printacr(#3#4+'--------------- ---- ----- ------- --------',abort,next); + with tot do + s:=#3#3+mln('Totals:',20)+' '+#3#4+mrn(cstr(pts),5)+' '+ + #3#4+mrn(cstrl(blks*128),7)+' '+#3#7+ctim(tt); + printacr(s,abort,next); + end; +end; + +procedure removebatchfiles; +var s:astr; + i:integer; +begin + if numbatchfiles=0 then begin + nl; print('Batch queue empty.'); + end else + repeat + nl; + prt('File # to remove (1-'+cstr(numbatchfiles)+') (?=list) : '); + input(s,2); i:=value(s); + if (s='?') then listbatchfiles; + if (i>0) and (i<=numbatchfiles) then begin + print('"'+stripname(batch[i].fn)+'" deleted out of queue.'); + delbatch(i); + end; + if (numbatchfiles=0) then print('Queue now empty.'); + until (s<>'?'); +end; + +procedure clearbatch; +begin + nl; + if pynq('Clear queue? ') then begin + numbatchfiles:=0; + batchtime:=0.0; + print('Queue now empty.'); + end; +end; + +end. diff --git a/file7.pas b/file7.pas new file mode 100644 index 0000000..9e348ed --- /dev/null +++ b/file7.pas @@ -0,0 +1,180 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file7; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + file0, + common; + +procedure recvascii(fn:astr; var dok:boolean; tpb:real); +procedure sendascii(fn:astr); + +implementation + +procedure recvascii(fn:astr; var dok:boolean; tpb:real); +var f:file; + r1:array[0..1023] of byte; + byte_count,start_time:longint; + bytes_this_line,kbyte_count,line_count:integer; + b:byte; + start,abort,error,done,timeo,kba,prompti:boolean; + c:char; + +(* procedure onec(var b:byte); + var r:real; + i:byte; + c:char; + bb:boolean; + begin + if (inhead[modemr.comport]<>intail[modemr.comport]) then begin + bb:=recom1(c); + b:=ord(c); + end else begin + r:=timer; + while (not async_buffer_check) and (tchk(r,90.0)) do checkhangup; + if (async_buffer_check) then b:=ord(ccinkey1) + else begin + timeo:=TRUE; + b:=0; + end; + if (timeo) then error:=TRUE; + if (hangup) then begin + error:=TRUE; done:=TRUE; + abort:=TRUE; + end; + end; + end;*) + + procedure checkkb; + var c:char; + begin + if (keypressed) then begin + c:=readkey; + if (c=#27) then begin + abort:=TRUE; done:=TRUE; kba:=TRUE; + nl; star('Aborted.'); + end; + end; + end; + +begin + abort:=FALSE; done:=FALSE; timeo:=FALSE; kba:=FALSE; + line_count:=0; start:=FALSE; + start_time:=trunc(timer); byte_count:=0; + assign(f,fn); + {$I-} rewrite(f,1); {$I+} + if (ioresult<>0) then begin + if (useron) then star('Disk error - sorry, unable to upload it.'); + done:=TRUE; abort:=TRUE; + end; + prompti:=pynq('Do you want prompted input?'); + if (useron) then star('Upload Ascii text. Press Ctrl-Z (^Z) when done'); + while (not done) and (not hangup) do begin + error:=TRUE; + checkkb; + if (kba) then begin + done:=TRUE; + abort:=TRUE; + end; + if (not kba) then + if (prompti) then begin + com_flush_rx; + sendcom1('>'); + end; + if (not done) and (not abort) and (not hangup) then begin + start:=FALSE; + error:=FALSE; + checkkb; + if (not done) then begin + bytes_this_line:=0; + repeat + getkey(c); b:=ord(c); + if (b=26) then begin + start:=TRUE; done:=TRUE; + nl; + if (useron) then star('End Of File Received'); + end else begin + if (b<>10) then begin (* ignore LF *) + r1[bytes_this_line]:=b; + bytes_this_line:=bytes_this_line+1; + end; + end; + until (bytes_this_line>250) or (b=13) or (timeo) or (done); + if (b<>13) then begin + r1[bytes_this_line]:=13; + bytes_this_line:=bytes_this_line+1; + end; + r1[bytes_this_line]:=10; + bytes_this_line:=bytes_this_line+1; + seek(f,byte_count); + {$I-} blockwrite(f,r1,bytes_this_line); {$I+} + if (ioresult<>0) then begin + nl; + if (useron) then star('Disk error'); + done:=TRUE; abort:=TRUE; + end; + inc(line_count); + byte_count:=byte_count+bytes_this_line; + end; + end; + end; + close(f); + kbyte_count:=0; + while (byte_count>1024) do begin + inc(kbyte_count); + byte_count:=byte_count-1024; + end; + if (byte_count>512) then inc(kbyte_count,1); + if (hangup) then abort:=TRUE; + if (abort) then erase(f) + else begin + star(cstr(line_count)+' lines, '+cstr(kbyte_count)+'k uploaded'); + if (timer0) then print('File not found.') else begin + abort:=FALSE; + print('^X = Abort -- ^S = Pause'); + print('Press to start ... '); nl; + repeat getkey(c) until (c=^M) or (hangup); + while (not hangup) and (not abort) and (not eof(f)) do begin + read(f,c); if (outcom) then sendcom1(c); + if (c<>^G) then write(c); + ckey; + end; + close(f); + prompt(^Z); + nl; nl; + star('File transmission complete.'); + end; +end; + +end. diff --git a/file8.pas b/file8.pas new file mode 100644 index 0000000..b4a898f --- /dev/null +++ b/file8.pas @@ -0,0 +1,338 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file8; + +interface + +uses + crt,dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + file0, file6, file7, + execbat, + common; + +procedure ymbadd(fname:astr); +procedure send1(fn:astr; var dok,kabort:boolean); +procedure receive1(fn:astr; resumefile:boolean; var dok,kabort,addbatch:boolean); + +implementation + +procedure abeep; +var a,b,c,i,j:integer; +begin + for j:=1 to 3 do begin + for i:=1 to 3 do begin + a:=i*500; + b:=a; + while (b>a-300) do begin + sound(b); + dec(b,50); + c:=a+1000; + while (c>a+700) do begin + sound(c); dec(c,50); + delay(2); + end; + end; + end; + delay(50); + nosound; + end; +end; + +function checkfileratio:integer; +var i,r,t:real; + j:integer; + badratio:boolean; +begin + t:=thisuser.dk; + if (numbatchfiles<>0) then + for j:=1 to numbatchfiles do begin + loaduboard(batch[j].section); + if (not (fbnoratio in memuboard.fbstat)) then + t:=t+(batch[j].blks div 8); + end; + badratio:=FALSE; + r:=(t+0.001)/(thisuser.uk+0.001); + if (r>systat.dlkratio[thisuser.sl]) then badratio:=TRUE; + i:=(thisuser.downloads+numbatchfiles+0.001)/(thisuser.uploads+0.001); + if (i>systat.dlratio[thisuser.sl]) then badratio:=TRUE; + if ((aacs(systat.nodlratio)) or (fnodlratio in thisuser.ac)) then + badratio:=FALSE; + if (not systat.uldlratio) then badratio:=FALSE; + checkfileratio:=0; + if (badratio) then + if (numbatchfiles=0) then checkfileratio:=1 else checkfileratio:=2; + loaduboard(fileboard); + if (fbnoratio in memuboard.fbstat) then checkfileratio:=0; +end; + +procedure ymbadd(fname:astr); +var t1,t2:real; + f:file of byte; + ff:ulfrec; + dt:datetimerec; + sof:longint; + ior:word; + slrn,rn,pl,fblks:integer; + slfn:astr; + ffo:boolean; +begin + ffo:=(filerec(ulff).mode<>fmclosed); + nl; + fname:=sqoutsp(fname); + if (exist(fname)) then begin + assign(f,fname); reset(f); + sof:=filesize(f); + fblks:=trunc((sof+127.0)/128.0); + t1:=rte*fblks; + close(f); + t2:=batchtime+t1; + if (t2>nsl) then print('Not enough time left in queue.') + else + if (numbatchfiles=20) then print('Batch queue full.') + else begin + inc(numbatchfiles); + with batch[numbatchfiles] do begin + if (fileboard<>-1) then begin + slrn:=lrn; slfn:=lfn; + if ffo then close(ulff); + recno(stripname(fname),pl,rn); + seek(ulff,rn); read(ulff,ff); + close(ulff); + if ffo then fiscan(pl); + lrn:=slrn; lfn:=slfn; + pts:=ff.filepoints; + blks:=ff.blocks; + end else begin + pts:=unlisted_filepoints; + blks:=fblks; + end; + + fn:=sqoutsp(fname); + tt:=t1; + section:=fileboard; + batchtime:=t2; + + sysoplog('Added '+stripname(fn)+' to batch queue.'); + sprint(fstring.batchadd); + r2dt(batchtime,dt); + print('Batch - Files: '+cstr(numbatchfiles)+' Time: '+longtim(dt)); + end; + end; + end else + print('File doesn''t exist'); +end; + +procedure addtologupdown; +var s:astr; +begin + s:=' ULs: '+cstr(trunc(thisuser.uk))+'k in '+cstr(thisuser.uploads)+' file'; + if thisuser.uploads<>1 then s:=s+'s'; + s:=s+' - DLs: '+cstr(trunc(thisuser.dk))+'k in '+cstr(thisuser.downloads)+' file'; + if thisuser.downloads<>1 then s:=s+'s'; + sysoplog(s); +end; + +procedure send1(fn:astr; var dok,kabort:boolean); +var f:text; + ff:file; + f1:ulfrec; + nfn,cp,slfn,s:astr; + st:real; + filsize:longint; + dcode:word; { dos exit code } + p,i,sx,sy,t,pl,rn,slrn,errlevel:integer; + g,c:char; + b,done1,foundit:boolean; +begin + done1:=FALSE; + reset(xf); + repeat + nl; + sprompt('^4Protocol (^0?^4=^0list^4) : ^3'); mpkey(s); + if (s='?') then begin + nl; + showprots(FALSE,TRUE,FALSE,FALSE); + end else begin + p:=findprot(s,FALSE,TRUE,FALSE,FALSE); + if (p=-99) then print('Invalid entry.') else done1:=TRUE; + end; + until (done1) or (hangup); + + dok:=TRUE; kabort:=FALSE; + if (-p in [1,2,3,4,12]) or (p in [1..200]) then + case checkfileratio of + 1:begin + nl; + sprint(fstring.unbalance); + nl; + prompt('You have DLed: '+cstr(trunc(thisuser.dk))+'k in '+cstr(thisuser.downloads)+' file'); + if thisuser.downloads<>1 then print('s') else nl; + prompt('You have ULed: '+cstr(trunc(thisuser.uk))+'k in '+cstr(thisuser.uploads)+' file'); + if thisuser.uploads<>1 then print('s') else nl; + nl; + print(' 1 upload for every '+cstr(systat.dlratio[thisuser.sl])+' downloads must be maintained.'); + print(' 1k must be uploaded for every '+cstr(systat.dlkratio[thisuser.sl])+'k downloaded.'); + sysoplog('Tried to download while ratio out of balance:'); + addtologupdown; + p:=-11; + end; + 2:begin + nl; + sprint(fstring.unbalance); + nl; + print('Assuming you download the files already in the batch queue,'); + print('your upload/download ratio would be out of balance.'); + sysoplog('Tried to add to batch queue while ratio out of balance:'); + addtologupdown; + p:=-11; + end; + end; + if (p>=0) then begin seek(xf,p); read(xf,protocol); end; + close(xf); + lastprot:=p; + case p of + -12:ymbadd(fn); + -11:; + -10:begin dok:=FALSE; kabort:=TRUE; end; +(* -4:if (incom) then send(TRUE,TRUE,fn,dok,kabort,FALSE,rte); + -3:if (incom) then send(FALSE,TRUE,fn,dok,kabort,FALSE,rte); + -2:if (incom) then send(FALSE,FALSE,fn,dok,kabort,FALSE,rte);*) + -1:if (not trm) then sendascii(fn); +(* -2:if (not trm) then begin + assign(f,fn); + {$I-} reset(f); {$I+} + if (ioresult<>0) then print('File not found.') + else begin + kabort:=FALSE; + clrscr; + sx:=wherex; sy:=wherey; + window(1,25,80,25); + textcolor(11); textbackground(1); + gotoxy(1,1); + for t:=1 to 80 do write(' '); + gotoxy(1,1); + write('Sending ASCII File '+fn+' -- Please Wait'); + textcolor(7); textbackground(0); + window(1,1,80,24); + gotoxy(sx,sy); + repeat + read(f,g); + o(g); write(g); + until (eof(f)) or (kabort); + close(f); + end; + end;*) + else + if (incom) then begin + cp:=bproline1(protocol.dlcmd); + bproline(cp,sqoutsp(fn)); + + if (useron) then star('Send ready.'); + if (useron) then shel(caps(thisuser.name)+' is downloading!') else + shel('Sending file(s)...'); + b:=systat.swapshell; systat.swapshell:=FALSE; + pexecbatch(FALSE,'tgtemp2.bat','tgtest2.$$$',start_dir,cp,errlevel); + systat.swapshell:=b; + shel2; + + foundit:=FALSE; i:=0; + while ((i<6) and (not foundit)) do begin + inc(i); + if (value(protocol.dlcode[i])=errlevel) then foundit:=TRUE; + end; + + dok:=TRUE; + if ((foundit) and (not (xbxferokcode in protocol.xbstat))) then dok:=FALSE; + if ((not foundit) and (xbxferokcode in protocol.xbstat)) then dok:=FALSE; + end; + end; + if (trm) then begin incom:=FALSE; outcom:=FALSE; end; + if (not useron) and (not kabort) then begin + cursoron(FALSE); + setwindow(wind,36,8,80,12,4,0,1); + gotoxy(3,2); tc(14); + if dok then write('Transfer successful.') else + write('Transfer unsuccessful.'); + st:=timer; + while (not keypressed) and (tcheck(st,5)) do abeep; + if keypressed then c:=readkey; + removewindow(wind); + cursoron(TRUE); + incom:=FALSE; outcom:=FALSE; + end; +end; + +procedure receive1(fn:astr; resumefile:boolean; var dok,kabort,addbatch:boolean); +var cp,nfn,s:astr; + st:real; + filsize:longint; + p,i,t,fno,sx,sy,nof,errlevel:integer; + c:char; + b,done1,foundit:boolean; +begin + done1:=FALSE; + reset(xf); + repeat + nl; + sprompt('^4Protocol (^0?^4=^0list^4) : ^3'); mpkey(s); + if (s='?') then begin + nl; + showprots(TRUE,FALSE,FALSE,resumefile); + end else begin + p:=findprot(s,TRUE,FALSE,FALSE,resumefile); + if (p=-99) then print('Invalid entry.') else done1:=TRUE; + end; + until (done1) or (hangup); + + if (not useron) then begin incom:=TRUE; outcom:=TRUE; end; + dok:=TRUE; kabort:=FALSE; + if (p>=0) then begin seek(xf,p); read(xf,protocol); end; + close(xf); + case p of + -12:addbatch:=TRUE; + -11,-10:begin dok:=FALSE; kabort:=TRUE; end; + -1:if (not trm) then recvascii(fn,dok,rte); + else + if (incom) then begin + cp:=bproline1(protocol.ulcmd); + bproline(cp,sqoutsp(fn)); + + if (useron) then star('Receive ready.'); + if (useron) then shel(caps(thisuser.name)+' is uploading!') else + shel('Receiving file(s)...'); + b:=systat.swapshell; systat.swapshell:=FALSE; + pexecbatch(FALSE,'tgtemp2.bat','tgtest2.$$$',start_dir,cp,errlevel); + systat.swapshell:=b; + shel2; + + foundit:=FALSE; i:=0; + while ((i<6) and (not foundit)) do begin + inc(i); + if (value(protocol.ulcode[i])=errlevel) then foundit:=TRUE; + end; + + dok:=TRUE; + if ((foundit) and (not (xbxferokcode in protocol.xbstat))) then dok:=FALSE; + if ((not foundit) and (xbxferokcode in protocol.xbstat)) then dok:=FALSE; + end; + end; + if (not useron) and (not kabort) then begin + cursoron(FALSE); + setwindow(wind,36,8,80,12,4,0,1); + gotoxy(3,2); tc(14); + if (dok) then write('Transfer successful.') else + write('Transfer unsuccessful.'); + st:=timer; + while (not keypressed) and (tcheck(st,5)) do abeep; + if (keypressed) then c:=readkey; + removewindow(wind); + cursoron(TRUE); + incom:=FALSE; outcom:=FALSE; + end; +end; + +end. diff --git a/file9.pas b/file9.pas new file mode 100644 index 0000000..95da685 --- /dev/null +++ b/file9.pas @@ -0,0 +1,348 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit file9; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + file0, file1, file2, + common; + +function info:astr; +procedure dir(cd,x:astr; expanded:boolean); +procedure dirf(expanded:boolean); +procedure deleteff(rn:integer; var pl:integer; killverbose:boolean); +procedure remove; +procedure setdirs; +procedure pointdate; +procedure yourfileinfo; +procedure listopts; + +implementation + +function align2(s:astr):astr; +begin + if pos('.',s)=0 then s:=mln(s,12) + else s:=mln(copy(s,1,pos('.',s)-1),8)+' '+mln(copy(s,pos('.',s)+1,3),3); + align2:=s; +end; + +function info:astr; +var pm:char; + i:integer; + s:astr; + dt:datetime; + + function ti(i:integer):astr; + var s:astr; + begin + ti:=tch(cstr(i)); + end; + +begin + s:=dirinfo.name; + if (dirinfo.attr and directory)=directory then s:=mln(s,13)+' ' + else s:=align2(s)+' '+mrn(cstrl(dirinfo.size),7); + unpacktime(dirinfo.time,dt); + with dt do begin + if hour<13 then pm:='a' else begin pm:='p'; hour:=hour-12; end; + s:=s+' '+mrn(cstr(month),2)+'-'+ti(day)+'-'+ti(year-1900)+ + ' '+mrn(cstr(hour),2)+':'+ti(min)+pm; + end; + info:=s; +end; + +procedure dir(cd,x:astr; expanded:boolean); +var abort,next,nofiles:boolean; + s:astr; + onlin:integer; + dfs:longint; + numfiles:integer; +begin + if (copy(cd,length(cd),1)<>'\') then cd:=cd+'\'; + abort:=FALSE; + cd:=cd+x; + if (fso) then begin + printacr(#3#5+' Directory of '+#3#3+copy(cd,1,length(cd)),abort,next); + nl; + end; + s:=''; onlin:=0; numfiles:=0; nofiles:=TRUE; + ffile(cd); + while (found) and (not abort) do begin + if (not (dirinfo.attr and directory=directory)) or (fso) then + if (not (dirinfo.attr and volumeid=volumeid)) then + if ((not (dirinfo.attr and dos.hidden=dos.hidden)) or (usernum=1)) then + if ((dirinfo.attr and dos.hidden=dos.hidden) and + (not (dirinfo.attr and directory=directory))) or + (not (dirinfo.attr and dos.hidden=dos.hidden)) then begin + nofiles:=FALSE; + if (expanded) then printacr(info,abort,next) + else begin + inc(onlin); + s:=s+align2(dirinfo.name); + if onlin<>5 then s:=s+' ' else begin + printacr(s,abort,next); + s:=''; onlin:=0; + end; + end; + inc(numfiles); + end; + nfile; + end; + if (not found) and (onlin in [1..5]) then printacr(s,abort,next); + dfs:=freek(exdrv(cd)); + if (nofiles) then s:=#3#3+'Files not found' + else s:=#3#3+mrn(cstr(numfiles)+#3#5+' File(s)',17); + printacr(s+#3#3+mrn(cstrl(dfs*1024),10)+#3#5+' bytes free',abort,next); +end; + +procedure dirf(expanded:boolean); +var fspec:astr; + abort,next,all:boolean; +begin + nl; + print('Raw directory.'); + gfn(fspec); abort:=FALSE; next:=FALSE; + nl; + loaduboard(fileboard); + dir(memuboard.dlpath,fspec,expanded); +end; + +procedure deleteff(rn:integer; var pl:integer; killverbose:boolean); +var i:integer; + f:ulfrec; + v:verbrec; +begin + if (rn<=pl) and (rn>0) then begin + dec(pl); + seek(ulff,rn); read(ulff,f); + if (f.vpointer<>-1) and (killverbose) then begin + assign(verbf,systat.gfilepath+'verbose.dat'); + reset(verbf); + seek(verbf,f.vpointer); read(verbf,v); + if (ioresult=0) then begin + v.descr[1]:=''; + seek(verbf,f.vpointer); write(verbf,v); + end; + close(verbf); + end; + for i:=rn to pl do begin + seek(ulff,i+1); read(ulff,f); + seek(ulff,i); write(ulff,f); + end; + seek(ulff,0); f.blocks:=pl; write(ulff,f); + end; +end; + +procedure remove; +var done,abort,next,subit:boolean; + c:char; + pl,rn:integer; + s,fn:astr; + ff:file; + f:ulfrec; + u:userrec; +begin + nl; + print('Remove files.'); + gfn(fn); abort:=FALSE; next:=FALSE; + nl; + recno(fn,pl,rn); + if (baddlpath) then exit; + if (fn='') or (pos('.',fn)=0) or (rn=0) then + print('No matching files.') + else begin + lastcommandovr:=TRUE; + c:=#0; + while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin + seek(ulff,rn); read(ulff,f); + reset(uf); seek(uf,f.owner); read(uf,u); + if (rn<>0) then begin + done:=FALSE; + repeat + if (c<>'?') then begin + nl; + fileinfo(f,FALSE,abort,next); + nl; + end; + if (next) then c:='N' else begin + prt('Remove files (?=help) : '); + if (f.owner<>usernum) and (not fso) then + onek(c,'QN?'^M) + else onek(c,'QDN?'^M); + end; + case c of + ^M:c:=#0; {* do nothing *} + '?':begin + nl; + print('Redisplay entry'); + if (f.owner<>usernum) and (not fso) then + lcmds(12,3,'Next file','Quit') + else begin + lcmds(12,3,'Delete file','Next file'); + lcmds(12,3,'Quit',''); + end; + nl; + end; + 'D':if (f.owner<>usernum) and (not fso) then + sprint(#3#7+'You can''t delete this!!') + else begin + deleteff(rn,pl,TRUE); + dec(lrn); + s:='Removed "'+sqoutsp(f.filename)+'" from Dir#'+cstr(fileboard); + nl; + if (not exist(memuboard.dlpath+f.filename)) then + sprint(#3#5+'File does not exist!') + else + if (fso) then + if pynq('Erase file too? ') then begin + assign(ff,memuboard.dlpath+f.filename); + {$I-} erase(ff); {$I+} + if (ioresult=0) then s:=s+' [FILE DELETED]' + else + s:='Tried deleting "'+sqoutsp(f.filename)+'" from Dir#'+cstr(fileboard); + end; + + subit:=(allcaps(f.stowner)=allcaps(u.name)); + if (fso) then + if (not subit) then begin + print('Uploader name does not match user name!'); + print('Cannot remove credit from user.'); + end else + subit:=pynq('Remove from '+#3#5+caps(u.name)+' #'+ + cstr(f.owner)+#3#7+'''s ratio? '); + + if (subit) then begin + if (f.owner=usernum) then u:=thisuser; + with u do begin + uk:=uk-(f.blocks div 8); + dec(uploads); + if (uk<0) then uk:=0; + if (uploads<0) then uploads:=0; + end; + seek(uf,f.owner); write(uf,u); + if (f.owner=usernum) then thisuser:=u; + end; + sysoplog(s); + done:=TRUE; + end; + else + done:=TRUE; + end; + until ((done) or (hangup)); + abort:=FALSE; next:=FALSE; + if (c='Q') then abort:=TRUE; + if (c<>'?') then nrecno(fn,pl,rn); + end; + end; + reset(uf); close(uf); + close(ulff); + end; +end; + +procedure setdirs; +var s:astr; + i:integer; + done:boolean; +begin + nl; + if (novice in thisuser.ac) then begin fbaselist; nl; end; + done:=FALSE; + repeat + prt('Set NewScan file bases (Q=Quit,?=List,#=Toggle base) : '); input(s,3); + if (s='Q') then done:=TRUE; + if (s='?') then begin fbaselist; nl; end; + i:=ccuboards[0][value(s)]; + if (fbaseac(i)) then { loads memuboard } + if (i>=0) and (i<=maxulb) and + (length(s)>0) and (s[1] in ['0'..'9']) then begin + nl; + sprompt(#3#5+memuboard.name+#3#3); + if (i in zscanr.fzscan) then begin + sprint(' will NOT be scanned.'); + zscanr.fzscan:=zscanr.fzscan-[i]; + end else begin + sprint(' WILL be scanned.'); + zscanr.fzscan:=zscanr.fzscan+[i]; + end; + nl; + end; + until (done) or (hangup); + lastcommandovr:=TRUE; + savezscanr; +end; + +procedure pointdate; +var s:astr; +begin + nl; + print('Enter limiting date for new files -'); + print('Date is currently set to '+newdate); + nl; + prt('(mm/dd/yy): '); input(s,8); + if (daynum(s)=0) then print('Illegal date.') else newdate:=s; + nl; + print('Current limiting date is '+newdate); +end; + +procedure yourfileinfo; +begin + nl; + with thisuser do begin + sprint(#3#4+'Name.........: '+#3#5+nam); + sprint(#3#4+'SL...........: '+#3#5+cstr(thisuser.sl)); + sprint(#3#4+'DSL..........: '+#3#5+cstr(thisuser.dsl)); + sprint(#3#4+'File points..: '+#3#5+cstr(thisuser.filepoints)); + sprompt(#3#4+'You DLed.....: '+#3#5+cstrl(thisuser.dk)+'k in '+cstr(thisuser.downloads)+' file'); + if (thisuser.downloads<>1) then sprint('s') else nl; + sprompt(#3#4+'You ULed.....: '+#3#5+cstrl(thisuser.uk)+'k in '+cstr(thisuser.uploads)+' file'); + if (thisuser.uploads<>1) then sprint('s') else nl; + sprint(#3#4+'File point status:'); + if (fnofilepts in thisuser.ac) then + sprint(#3#3+' Special flag - No file point check!') + else + if (aacs(systat.nofilepts)) then + sprint(#3#3+' High security level - No file point check!') + else + sprint(#3#5+' Active according to setting on each file.'); + if (not systat.fileptratio) then + sprint(#3#3+' Auto file point compensation inactive.') + else begin + sprint(#3#5+' File point compensation of '+cstr(systat.fileptcomp)+' to 1.'); + sprint(#3#5+' Base compensation size of '+cstr(systat.fileptcompbasesize)+'k.'); + end; + sprint(#3#4+'UL/DL ratio settings:'); + if (not systat.uldlratio) then + sprint(#3#3+' Inactive.') + else + if (fnodlratio in thisuser.ac) then + sprint(#3#3+' Special flag - No ratio check!') + else + if (aacs(systat.nodlratio)) then + sprint(#3#3+' High security level - No ratio check!') + else begin + sprint(#3#5+' 1 upload for every '+cstr(systat.dlratio[thisuser.sl])+' downloads'); + sprint(#3#5+' 1k upload for every '+cstr(systat.dlkratio[thisuser.sl])+' downloaded'); + end; + end; +end; + +procedure listopts; +var c:char; +begin + nl; + prt('List version: (1-3) ['+cstr(thisuser.flistopt)+'] : '); onek(c,'Q123 '^M); + if (c in ['1'..'3']) then thisuser.flistopt:=ord(c)-48; + if (thisuser.flistopt in [1,3]) then begin + dyny:=flistverb; + flistverb:=pynq('List verbose descriptions? ['+syn(flistverb)+'] : '); + end; + lastcommandovr:=TRUE; +end; + +end. diff --git a/file_id.diz b/file_id.diz new file mode 100644 index 0000000..7732bb4 --- /dev/null +++ b/file_id.diz @@ -0,0 +1,5 @@ +------------------------------------ +-- Telegard Bulletin Board System -- +-- Version 2.5i Standard -- +-- Source code in Pascal -- +------------------------------------ \ No newline at end of file diff --git a/findit.pas b/findit.pas new file mode 100644 index 0000000..592e222 --- /dev/null +++ b/findit.pas @@ -0,0 +1,34 @@ +uses dos; + +var s,spath:string; + ps:dirstr; + ns:namestr; + es:extstr; + notfound:boolean; + +begin + writeln; + writeln('Find EXE/COM/BAT files on the PATH.'); + writeln; + writeln('Enter commandline:'); + write(':'); readln(s); + + while (copy(s,1,1)=' ') do s:=copy(s,2,length(s)-1); + + fsplit(s,ps,ns,es); + + notfound:=FALSE; + s:=ns+'.EXE'; spath:=fsearch(s,getenv('PATH')); + if (spath='') then begin + s:=ns+'.COM'; spath:=fsearch(s,getenv('PATH')); + if (spath='') then begin + s:=ns+'.BAT'; spath:=fsearch(s,getenv('PATH')); + if (spath='') then notfound:=TRUE; + end; + end; + + if (not notfound) then spath:=fexpand(spath); + + if (notfound) then writeln('Not found.') else writeln('Found: '+spath); + +end. diff --git a/func.pas b/func.pas new file mode 100644 index 0000000..7a4656d --- /dev/null +++ b/func.pas @@ -0,0 +1,92 @@ +const + ESCAPE = 27; + F1 = 59; + F2 = 60; + F3 = 61; + F4 = 62; + F5 = 63; + F6 = 64; + F7 = 65; + F8 = 66; + F9 = 67; + F10 = 68; + SHIFT_F1 = 84; + SHIFT_F2 = 85; + SHIFT_F3 = 86; + SHIFT_F4 = 87; + SHIFT_F5 = 88; + SHIFT_F6 = 89; + SHIFT_F7 = 90; + SHIFT_F8 = 91; + SHIFT_F9 = 92; + SHIFT_F10 = 93; + CTRL_F1 = 94; + CTRL_F2 = 95; + CTRL_F3 = 96; + CTRL_F4 = 97; + CTRL_F5 = 98; + CTRL_F6 = 99; + CTRL_F7 = 100; + CTRL_F8 = 101; + CTRL_F9 = 102; + CTRL_F10 = 103; + ALT_F1 = 104; + ALT_F2 = 105; + ALT_F3 = 106; + ALT_F4 = 107; + ALT_F5 = 108; + ALT_F6 = 109; + ALT_F7 = 110; + ALT_F8 = 111; + ALT_F9 = 112; + ALT_F10 = 113; + ALT_Q = 16; + ALT_W = 17; + ALT_E = 18; + ALT_R = 19; + ALT_T = 20; + ALT_Y = 21; + ALT_U = 22; + ALT_I = 23; + ALT_O = 24; + ALT_P = 25; + ALT_A = 30; + ALT_S = 31; + ALT_D = 32; + ALT_F = 33; + ALT_G = 34; + ALT_H = 35; + ALT_J = 36; + ALT_K = 37; + ALT_L = 38; + ALT_Z = 44; + ALT_X = 45; + ALT_C = 46; + ALT_V = 47; + ALT_B = 48; + ALT_N = 49; + ALT_M = 50; + CTRL_PRTSC = 114; + ALT_1 = 120; + ALT_2 = 121; + ALT_3 = 122; + ALT_4 = 123; + ALT_5 = 124; + ALT_6 = 125; + ALT_7 = 126; + ALT_8 = 127; + ALT_9 = 128; + ALT_0 = 129; + ALT_MINUS = 130; + ALT_EQUAL = 131; + ARROW_HOME = 71; + ARROW_UP = 72; + ARROW_PGUP = 73; + ARROW_LEFT = 75; + ARROW_RIGHT = 77; + ARROW_END = 79; + ARROW_DOWN = 80; + ARROW_PGDN = 81; + CTRL_HOME = 119; + CTRL_END = 117; + diff --git a/fvtype.pas b/fvtype.pas new file mode 100644 index 0000000..58de8ca --- /dev/null +++ b/fvtype.pas @@ -0,0 +1,141 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit fvtype; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + mdek, myio, timejunk; + +procedure findvertypeout(s:string; + var vercs:string; + var vertype:string; + var vertypes:byte; + var serialnumber:longint; + var siteinfo:string; + var sitedatetime:packdatetime); + +implementation + +type + infoheaderrec=array[1..6] of byte; + +const + infoheader:infoheaderrec=($FA,$CD,$20,$EF,$02,$AA); + +procedure domessage; +var x,y,cx,c1,c2:integer; + c:char; +begin + cursoron(FALSE); + clrscr; + writeln(' ÛßßÜ ÜßßÜ ÛÜ Û Û ßßÛßß ÛÜ ÜÛ Ûßßßß Üßßßß Üßßßß'); + writeln(' Û Û Û Û Û ßÜÛ Û Û ß Û Ûßßß ßßßÜ ßßßÜ'); + writeln(' ßßß ßß ß ß ß ß ß ßßßßß ßßßß ßßßß'); + writeln; + writeln(' Û Û Û ßÛß ßßÛßß Û Û'); + writeln(' Û Û Û Û Û ÛßßßÛ'); + writeln(' ßß ßß ßßß ß ß ß'); + writeln; + writeln(' ßßÛßß Û Û Ûßßßß ÛßßßÜ ÛßßßÜ Üßßßß ÛÛ ÛÛÛ'); + writeln(' Û ÛßßßÛ Ûßßß ÛßßßÜ ÛßßßÜ ßßßÜ ßß ßßß'); + writeln(' ß ß ß ßßßßß ßßßß ßßßß ßßßß ßß ßßß'); + writeln; + writeln; + writeln(' Analysis of the BBS.EXE and BBS.OVR files has shown'); + writeln(' that they have been tampered with. Don''t do it again!!'); + writeln(' We - the authors of this BBS - feel it is already a pretty'); + writeln(' good piece of software... don''t mess with it!'); + writeln; + c1:=0; + + {rcg11172000 this doesn't fly under Linux. Is this all necessary anyway?} + repeat + { + for x:=39 downto 2 do begin + cx:=cx mod 3+1; + case cx of 1:c1:=4; 2:c1:=12; 3:c1:=14; end; + case cx of 1:c2:=12; 2:c2:=14; 3:c2:=15; end; + inline($FA); + for y:=1 to 11 do begin + mem[vidseg:(160*(y-1)+2*(x-1))+1]:=c1; + mem[vidseg:(160*(y-1)+2*((79-x)-1))+1]:=c1; + end; + delay(1); + inline($FB); + end; + } + until (keypressed); + c:=readkey; + cursoron(TRUE); + gotoxy(1,19); + halt(255); +end; + +procedure findvertypeout(s:string; + var vercs:string; + var vertype:string; + var vertypes:byte; + var serialnumber:longint; + var siteinfo:string; + var sitedatetime:packdatetime); +var f:file; + rs:string; + r:array[1..144] of byte; + chk,chk1,chk2:word; + i,res:integer; + b1,b2:byte; + + procedure decryptinfo; + var s:string; + i:integer; + begin + for i:=13 to 142 do s[i-12]:=chr(r[i]); s[0]:=chr(132); + s:=decrypt(s,r[7],r[8],r[9],r[10],r[11],r[12]); + for i:=13 to 142 do r[i]:=ord(s[i-12]); + end; + +begin + vertype:='Standard'; vertypes:=0; vercs:=''; + filemode:=0; assign(f,s); reset(f,1); + seek(f,filesize(f)-144); blockread(f,r,144,res); + close(f); filemode:=2; + + for i:=1 to 6 do + if (r[i]<>infoheader[i]) then exit; + + decryptinfo; + + chk:=0; + + for i:=13 to 142 do inc(chk,r[i]); + chk1:=(chk div 6)*5; + chk2:=(chk div 19)*25; + b1:=chk1 mod 256; + b2:=chk2 mod 256; + if ((r[143]<>b1) or (r[144]<>b2)) then domessage; + vertypes:=r[19]; + case (r[19] and $07) of + $01:begin vercs:='à'; vertype:='Alpha'; end; + $02:begin vercs:='€'; vertype:='Center'; end; + $03:begin vercs:='á'; vertype:='Beta'; end; + $04:begin vercs:='ä'; vertype:='Special'; end; + else begin vercs:=''; vertype:='Standard'; end; + end; + if (r[19] and $10=$10) then vertype:=vertype+' Node'; + if (r[19] and $08=$08) then begin + vercs:=vercs+'$'; + if (vertype='Standard') then vertype:='Registered' + else vertype:='Registered '+vertype; + end; + serialnumber:=r[20]+(r[21] shl 8)+(r[22] shl 16)+(r[23] shl 24); + for i:=1 to 6 do sitedatetime[i]:=r[12+i]; + siteinfo:=''; + for i:=1 to r[24] do siteinfo:=siteinfo+chr(r[i+24]); +end; + +end. diff --git a/gloasync.inc b/gloasync.inc new file mode 100644 index 0000000..62c4eb2 --- /dev/null +++ b/gloasync.inc @@ -0,0 +1,141 @@ +(*---------------------------------------------------------------------** +** ** +** COMMUNICATIONS HARDWARE ADDRESSES ** +** ** +** These are specific to IBM PCs and close compatibles. ** +** ** +**---------------------------------------------------------------------*) + +const + UART_THR = $00; { offset from base of UART Registers for IBM PC } + UART_RBR = $00; + UART_IER = $01; + UART_IIR = $02; + UART_LCR = $03; + UART_MCR = $04; + UART_LSR = $05; + UART_MSR = $06; + + I8088_IMR = $21; { port address of the Interrupt Mask Register } + + COM1_Base = $03F8; { port addresses for the UART } + COM2_Base = $02F8; + COM3_Base = $03E8; + COM4_Base = $02E8; + + COM1_Irq = 4; { Interrupt line for the UART } + COM2_Irq = 3; + COM3_Irq = 4; + COM4_Irq = 3; + + RS232_Base = $0400; { Address of RS 232 com port pointer } + + MaxComPorts = 4; { Four ports allowed by this code } + +const + { Port addresses of each com port } + default_com_base:array[1..maxcomports] of word = + ( COM1_Base, COM2_Base, COM3_Base, COM4_Base ); + + { IRQ line for each port } + default_com_irq:array[1..maxcomports] of integer = + ( COM1_Irq, COM2_Irq, COM3_Irq, COM4_Irq ); + + {----------------------------------------------------------------------} + { } + { COMMUNICATIONS BUFFER VARIABLES } + { } + { The communications buffers are implemented as circular (ring) } + { buffers, or double-ended queues. The asynchronous I/O routines } + { enter characters in the receive buffer as they arrive at the } + { serial port. Higher-level routines may extract characters from } + { the receive buffer at leisure. Higher-level routines insert } + { characters into the send buffer. The asynchronous I/O routines } + { then send characters out the serial port when possible. } + { } + {----------------------------------------------------------------------} + +const + timeout = 256; { TimeOut value } + async_xon = ^Q; { XON character } + async_xoff = ^S; { XOFF character } + + async_overrun_error = 2; { overrun } + async_parity_error = 4; { parity error } + async_framing_error = 8; { framing error } + async_break_found = 16; { break interrupt } + + async_cts = $10; { Clear to send } + async_dsr = $20; { Data set ready } + +type + async_buffer_type = array[0..1] of char; { I/O buffer type for serial port } + async_ptr = ^async_buffer_type; + +var + com_base:array[1..maxcomports] of word; { Port addresses for serial ports } + com_irq:array[1..maxcomports] of integer; { IRQ line for each serial port } + +const async_buffer_max=5120; + +var + async_buffer:array[0..async_buffer_max] of char; + + async_buffer_ptr : async_ptr; { Input buffer address } + async_obuffer_ptr : async_ptr; { Output buffer address } + + async_open_flag : boolean; { true if port opened } + async_port, { current open port number (1 -- 4) } + async_base, { base for current open port } + async_irq, { IRQ for current open port } + async_rs232 : integer; { RS232 address for current port } + + async_buffer_overflow : boolean; { True if buffer overflow has happened } + async_buffer_used, { Amount of input buffer used so far } + async_maxbufferused : integer; { Maximum amount of input buffer used } + + { Async_Buffer empty if Head = Tail } + async_buffer_head, { Loc in Async_Buffer to put next char } + async_buffer_tail, { Loc in Async_Buffer to get next char } + async_buffer_newtail : integer; { For updating tail value } + + async_obuffer_overflow : boolean; { True if buffer overflow has happened } + async_obuffer_used, { Amount of output buffer used } + async_maxobufferused : integer; { Max amount of output buffer used } + + { Async_OBuffer empty if Head = Tail } + async_obuffer_head, { Loc in Async_OBuffer to put next char } + async_obuffer_tail, { Loc in Async_OBuffer to get next char } + async_obuffer_newtail : integer; { For updating tail value } + + async_buffer_low, { Low point in receive buffer for XON } + async_buffer_high, { High point in receive buffer for XOFF} + async_buffer_high_2 : integer; { Emergency point for XOFF } + + async_xoff_sent, { If XOFF sent } + async_send_xoff, { TRUE to send XOFF ASAP } + async_xoff_received, { If XOFF received } + async_xoff_rec_display, { If XOFF received } + async_xon_rec_display : boolean; { If XOFF received } + async_baud_rate : word; { Current baud rate } + + async_save_iaddr : pointer; { Save previous serial interrupt status} + async_do_cts, { TRUE to do clear-to-send checking } + async_do_dsr, { TRUE to do data-set-ready checking } + async_do_xonxoff, { TRUE to do XON/XOFF flow checking } + async_hard_wired_on : boolean; { TRUE if hard-wired connection } + async_break_length : integer; { Length of break in 1/10 seconds } + async_line_status, { Line Status Reg at interrupt } + async_modem_status, { Modem Status Reg at interrupt } + async_line_error_flags : byte; { Line status bits accumulated } + async_buffer_size, { Stores input buffer size } + async_obuffer_size, { Stores output buffer size } + async_uart_IER, { Interrupt enable register address } + async_uart_IIR, { Interrupt ID register address } + async_uart_MSR, { Modem status register address } + async_uart_LSR, { Line status register address } + async_output_delay, { Delay in ms when output buffer full } + async_onemsdelay : integer; { Loop count value to effect 1 ms delay} + + async_send_addr : async_ptr; { pointer to Async_Send routine } + diff --git a/globtype.inc b/globtype.inc new file mode 100644 index 0000000..0195e47 --- /dev/null +++ b/globtype.inc @@ -0,0 +1,17 @@ +{ Global Declarations } + +{ 8086/8088 hardware flags } +const + carry_flag = 1; + parity_flag = 4; + aux_carry_flag = 16; + zero_flag = 64; + sign_flag = 128; + +type + anystr = string[255]; (* Matches any string for parameter passing *) + shortstr = string[30]; (* Short string *) + keystr = string[65]; (* Function key string *) + filestr = string[65]; (* File name string *) + text_file = text; + diff --git a/go.bat b/go.bat new file mode 100644 index 0000000..757afe3 --- /dev/null +++ b/go.bat @@ -0,0 +1,6 @@ +cd\bbs2 +copy BBS*.* c:\temp +cd\tg25i +copy bbs.exe c:\bbs2 +copy bbs.ovr c:\bbs2 + \ No newline at end of file diff --git a/go.~ba b/go.~ba new file mode 100644 index 0000000..40c29a6 --- /dev/null +++ b/go.~ba @@ -0,0 +1,3 @@ +copy bbs.exe c:\temp +copy bbs.ovr c:\temp + \ No newline at end of file diff --git a/ifl.inc b/ifl.inc new file mode 100644 index 0000000..33b8ed5 --- /dev/null +++ b/ifl.inc @@ -0,0 +1,119 @@ +{* IFL - Interior File Listing Utility + * Copyright 1989 by Martin Pollard. Turbo Pascal version by Eric Oman. + * + * This header file contains constants and definitions used in + * the main program. + * + * Version 1.00 - 02/11/89 + * Version 1.10 - 02/24/89 + * Version 1.11 - 03/01/89 + * Version 1.20 - 03/15/89 + * + * Version 1.21 - 03/17/89 + *} + +const + L_SIG=$04034b50; {* ZIP local file header signature *} + C_SIG=$02014b50; {* ZIP central dir file header signature *} + E_SIG=$06054b50; {* ZIP end of central dir signature *} + Z_TAG=$fdc4a7dc; {* ZOO entry identifier *} + + HEADER_1= ' Length Size Now % Method Date Time Filename'; + HEADER_2= '-------- -------- --- --------- -------- ------ ------------'; + FOOTER_1= '-------- -------- --- ------------'; + + EXTS=5; {* number of default extensions *} + + filext:array[0..EXTS-1] of string = ( + '.ZIP', {* ZIP format archive *} + '.ARC', {* ARC format archive *} + '.PAK', {* ARC format archive (PAK.EXE) *} + '.ZOO', {* ZOO format archive *} + '.ARK'); {* ARC format archive (CP/M ARK.COM) *} + + errmsg:array[0..5] of string = ( + 'Unable to access specified file', + 'Unexpected end of file', + 'Unexpected read error', + 'Invalid header ID encountered', + 'Can''t find next entry in archive', + 'File is not in ARC/ZIP/ZOO archive format'); + + method:array[0..13] of string = ( + 'Directory', {* Directory marker *} + 'Unknown! ', {* Unknown compression type *} + 'Stored ', {* No compression *} + 'Packed ', {* Repeat-byte compression *} + 'Squeezed ', {* Huffman with repeat-byte compression *} + 'crunched ', {* Obsolete LZW compression *} + 'Crunched ', {* LZW 9-12 bit with repeat-byte compression *} + 'Squashed ', {* LZW 9-13 bit compression *} + 'Crushed ', {* LZW 2-13 bit compression *} + 'Shrunk ', {* LZW 9-13 bit compression *} + 'Reduced 1', {* Probabilistic factor 1 compression *} + 'Reduced 2', {* Probabilistic factor 2 compression *} + 'Reduced 3', {* Probabilistic factor 3 compression *} + 'Reduced 4'); {* Probabilistic factor 4 compression *} + +type + arcfilerec=record {* structure of ARC archive file header *} + filename:array[0..12] of char; {* filename *} + c_size:longint; {* compressed size *} + mod_date:integer; {* last mod file date *} + mod_time:integer; {* last mod file time *} + crc:integer; {* CRC *} + u_size:longint; {* uncompressed size *} + end; + + zipfilerec=record {* structure of ZIP archive file header *} + version:integer; {* version needed to extract *} + bit_flag:integer; {* general purpose bit flag *} + method:integer; {* compression method *} + mod_time:integer; {* last mod file time *} + mod_date:integer; {* last mod file date *} + crc:longint; {* CRC-32 *} + c_size:longint; {* compressed size *} + u_size:longint; {* uncompressed size *} + f_length:integer; {* filename length *} + e_length:integer; {* extra field length *} + end; + + zoofilerec=record {* structure of ZOO archive file header *} + tag:longint; {* tag -- redundancy check *} + typ:byte; {* type of directory entry (always 1 for now) *} + method:byte; {* 0 = Stored, 1 = Crunched *} + next:longint; {* position of next directory entry *} + offset:longint; {* position of this file *} + mod_date:word; {* modification date (DOS format) *} + mod_time:word; {* modification time (DOS format) *} + crc:word; {* CRC *} + u_size:longint; {* uncompressed size *} + c_size:longint; {* compressed size *} + major_v:char; {* major version number *} + minor_v:char; {* minor version number *} + deleted:byte; {* 0 = active, 1 = deleted *} + struc:char; {* file structure if any *} + comment:longint; {* location of file comment (0 = none) *} + cmt_size:word; {* length of comment (0 = none) *} + fname:array[0..12] of char; {* filename *} + var_dirlen:integer; {* length of variable part of dir entry *} + tz:char; {* timezone where file was archived *} + dir_crc:word; {* CRC of directory entry *} + end; + + outrec=record {* output information structure *} + filename:string[255]; {* output filename *} + date:integer; {* output date *} + time:integer; {* output time *} + typ:integer; {* output storage type *} + csize:longint; {* output compressed size *} + usize:longint; {* output uncompressed size *} + end; + +var + accum_csize:longint; {* compressed size accumulator *} + accum_usize:longint; {* uncompressed size accumulator *} + files:integer; {* number of files *} + level:integer; {* output directory level *} + filetype:integer; {* file type (1=ARC, 2=ZIP, 3=ZOO) *} + diff --git a/ifl.pas b/ifl.pas new file mode 100644 index 0000000..51dcc2d --- /dev/null +++ b/ifl.pas @@ -0,0 +1,481 @@ +{* IFL - Interior File Listing Utility + * Copyright 1989 by Martin Pollard. Turbo Pascal version by Eric Oman. + * + * IFL produces a listing of files contained in an archive file. + * Archive formats supported by IFL include: + * + * ARC - Developed by System Enhancement Associates + * and enhanced by PKware (PKARC & PKPAK) + * and NoGate Consulting (PAK) + * ZIP - Developed by PKware + * ZOO - Developed by Rahul Dhesi + * + * Version history: + * + * 1.00 02/11/89 Initial release. + * 1.10 02/24/89 1. Added support for archives created with SEA's + * ARC 6.x, which uses new header codes to support + * subdirectory archiving. + * 2. Restructured much of the code, which made no + * operational difference but resulted in a much + * "cleaner" source file. + * 3. Added automatic extension support. IFL will now + * cycle through all supported extensions until it + * finds the desired file. + * 1.11 03/01/89 Fixed a minor bug in which a non-archive file may + * be mistaken for a ZIP archive when the first byte + * is "P" (50h) but the second is not "K" (4Bh). + * (This version was never released.) + * 1.20 03/15/89 1. Added ZOO archive support. + * 2. The message line above the headings was changed + * to "Archive contains the following + * files:". The drive and pathname is no longer + * displayed before the filename. + * + * 1.21 03/17/89 Converted all C code into Turbo Pascal 5.0 code. + * + *} + +uses + dos; {* turbo3 and crt units intentionally unused + to allow redirection of I/O *} + + +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +{$I ifl.inc} + +const + VERSION = '1.21'; + __DATE__ = 'Mar 17 1989'; + +var + arc:arcfilerec; + zip:zipfilerec; + zoo:zoofilerec; + out:outrec; + +{*------------------------------------------------------------------------*} + + {* Miscellaneous string/numeric manipulation routines. + *} + +function cstr(l:longint):string; +var s:string; +begin + str(l,s); + cstr:=s; +end; + +function mrn(s:string; w:integer; c:char):string; +begin + while length(s)12 then dec(month,12); {* adjust for month > 12 *} + if year>99 then dec(year,100); {* adjust for year > 1999 *} + if hour>23 then dec(hour,24); {* adjust for hour > 23 *} + if minute>59 then dec(minute,60); {* adjust for minute > 59 *} + + if hour<12 then ampm:='a' else ampm:='p'; {* determine AM/PM *} + if hour=0 then hour:=12; {* convert 24-hour to 12-hour *} + if hour>12 then dec(hour,12); + + if out.usize=0 then ratio:=0 else {* ratio is 0% for null-length file *} + ratio:=100-((out.csize*100) div out.usize); + if ratio>99 then ratio:=99; + + outp:=mn(out.usize,8)+' '+mn(out.csize,8)+' '+mn(ratio,2)+'% '+ + mrn(method[typ],9,' ')+' '+mn(month,2)+'-'+mnz(day,2)+'-'+ + mnz(year,2)+' '+mn(hour,2)+':'+mnz(minute,2)+ampm+' '; + + if level>0 then outp:=outp+mrn('',level,' '); {* spaces for dirs (ARC only)*} + + outp:=outp+out.filename; + writeln(outp); + + if typ=0 then inc(level) {* bump dir level (ARC only) *} + else begin + inc(accum_csize,out.csize); {* adjust accumulators and counter *} + inc(accum_usize,out.usize); + inc(files); + end; +end; + +{*------------------------------------------------------------------------*} + +procedure final; +var ratio:longint; + outp:string; +begin + {* final - Display final totals and information. + *} + + if accum_usize=0 then ratio:=0 {* ratio is 0% if null total length *} + else + ratio:=100-((accum_csize*100) div accum_usize); + if ratio>99 then ratio:=99; + + outp:=mn(accum_usize,8)+' '+mn(accum_csize,8)+' '+mn(ratio,2)+ + '% '+cstr(files)+' file'; + if files<>1 then outp:=outp+'s'; + writeln(FOOTER_1); + writeln(outp); +end; + +{*------------------------------------------------------------------------*} + +function getbyte(var fp:file):char; +var c:char; + buf:array[0..0] of char; + numread:word; +begin + {* getbyte - Obtains character from file pointed to by fp. + * Aborts to DOS on error. + *} + + blockread(fp,c,1,numread); + if numread=0 then begin + close(fp); + abend(errmsg[1]); + end; + getbyte:=c; +end; + +{*------------------------------------------------------------------------*} + +procedure arc_proc(var fp:file); +var i,typ,stat:integer; + c:char; + numread:word; +begin + {* arc_proc - Process entry in ARC archive. + *} + + repeat + c:=getbyte(fp); + typ:=ord(getbyte(fp)); {* get storage method *} + case typ of + 0:exit; {* end of archive file *} + 1,2:out.typ:=2; {* Stored *} + 3,4:out.typ:=typ; {* Packed & Squeezed *} + 5,6,7:out.typ:=typ; {* crunched *} + 8,9,10:out.typ:=typ-2; {* Crunched, Squashed & Crushed *} + 30:out.typ:=0; {* Directory *} + 31:dec(level); {* end of dir (not displayed) *} + else + out.typ:=1; {* Unknown! *} + end; + if typ<>31 then begin {* get data from header *} + blockread(fp,arc,23,numread); if numread<>23 then abend(errmsg[2]); + if typ=1 then {* type 1 didn't have c_size field *} + arc.u_size:=arc.c_size + else begin + blockread(fp,arc.u_size,4,numread); + if numread<>4 then abend(errmsg[2]); + end; + i:=0; + repeat + inc(i); + out.filename[i]:=arc.filename[i-1]; + until (arc.filename[i]=#0) or (i=13); + out.filename[0]:=chr(i); + out.date:=arc.mod_date; + out.time:=arc.mod_time; + if typ=30 then begin + arc.c_size:=0; {* set file size entries *} + arc.u_size:=0; {* to 0 for directories *} + end; + out.csize:=arc.c_size; {* set file size entries *} + out.usize:=arc.u_size; {* for normal files *} + details; + if typ<>30 then begin + {$I-} seek(fp,filepos(fp)+arc.c_size); {$I+} {* seek to next entry *} + if ioresult<>0 then abend(errmsg[4]); + end; + end; + until c<>#$1a; + abend(errmsg[3]); +end; + +{*------------------------------------------------------------------------*} + +procedure zip_proc(var fp:file); +var i,stat:integer; + signature:longint; + c:char; + buf:array[0..25] of byte; + numread:word; +begin + {* zip_proc - Process entry in ZIP archive. + *} + + while TRUE do begin {* set up infinite loop (exit is within loop) *} + blockread(fp,signature,4,numread); if numread<>4 then abend(errmsg[2]); + if (signature=C_SIG) or (signature=E_SIG) then + exit; + if signature<>L_SIG then + abend(errmsg[3]); + blockread(fp,zip,26,numread); if numread<>26 then abend(errmsg[2]); + out.filename:=''; + for i:=1 to zip.f_length do {* get filename *} + out.filename[i]:=getbyte(fp); + out.filename[0]:=chr(zip.f_length); + if zip.e_length>0 then {* skip comment if present *} + for i:=1 to zip.e_length do + c:=getbyte(fp); + out.date:=zip.mod_date; + out.time:=zip.mod_time; + out.csize:=zip.c_size; + out.usize:=zip.u_size; + case zip.method of + 0:out.typ:=2; {* Stored *} + 1:out.typ:=9; {* Shrunk *} + 2,3,4,5: + out.typ:=zip.method+8; {* Reduced *} + else + out.typ:=1; {* Unknown! *} + end; + details; + {$I-} seek(fp,filepos(fp)+zip.c_size); {$I+} {* seek to next entry *} + if ioresult<>0 then abend(errmsg[4]); + end; +end; + +{*------------------------------------------------------------------------*} + +procedure zoo_proc(var fp:file); +var i,method:integer; + zoo_longname,zoo_dirname:string[255]; + numread:word; + namlen,dirlen:byte; +begin + {* zoo_proc - Process entry in ZOO archive. + *} + + while TRUE do begin {* set up infinite loop (exit is within loop) *} + blockread(fp,zoo,56,numread); if numread<>56 then abend(errmsg[2]); + if zoo.tag<>Z_TAG then abend(errmsg[3]); {* abort if invalid tag *} + if zoo.next=0 then exit; + + namlen:=ord(getbyte(fp)); dirlen:=ord(getbyte(fp)); + zoo_longname:=''; zoo_dirname:=''; + if namlen>0 then + for i:=1 to namlen do {* get long filename *} + zoo_longname:=zoo_longname+getbyte(fp); + if dirlen>0 then begin + for i:=1 to dirlen do {* get directory name *} + zoo_dirname:=zoo_dirname+getbyte(fp); + if copy(zoo_dirname,length(zoo_dirname),1)<>'/' then + zoo_dirname:=zoo_dirname+'/'; + end; + if zoo_longname<>'' then out.filename:=zoo_longname + else begin + i:=0; + repeat + inc(i); + out.filename[i]:=zoo.fname[i-1]; + until (zoo.fname[i]=#0) or (i=13); + out.filename[0]:=chr(i); + out.filename:=zoo_dirname+out.filename; + end; + out.date:=zoo.mod_date; {* set up fields *} + out.time:=zoo.mod_time; + out.csize:=zoo.c_size; + out.usize:=zoo.u_size; + method:=zoo.method; + case method of + 0:out.typ:=2; {* Stored *} + 1:out.typ:=6; {* Crunched *} + else + out.typ:=1; {* Unknown! *} + end; + if not (zoo.deleted=1) then details; + + {$I-} seek(fp,zoo.next); {$I+} {* seek to next entry *} + if ioresult<>0 then abend(errmsg[4]); + end; +end; + +{*------------------------------------------------------------------------*} + +procedure usage; +begin + {* usage - Displays help screen for people who can't comprehend how to + * use a simple program like this! Returns ERRORLEVEL of 2. + *} + + writeln; + writeln('IFL v'+VERSION+' - '+__DATE__+' - Interior File Listing Utility'); + writeln('Copyright 1989 by Martin Pollard. Turbo Pascal version by Eric Oman'); + writeln; + writeln('Syntax is: "IFL filename"'); + writeln; + writeln('IFL produces a listing of files contained in an archive file.'); + writeln('Archive formats currently supported include:'); + writeln; + writeln(' ARC - Developed by System Enhancement Associates'); + writeln(' and enhanced by PKware (PKARC & PKPAK)'); + writeln(' and NoGate Consulting (PAK)'); + writeln(' ZIP - Developed by PKware'); + writeln(' ZOO - Developed by Rahul Dhesi'); + writeln; + writeln('Support for other formats may be included in the future.'); + halt(2); +end; + +{*------------------------------------------------------------------------*} + +function exist(fn:string):boolean; +var fp:file; +begin + assign(fp,fn); + {$I-} reset(fp); {$I+} + if ioresult=0 then begin + close(fp); + exist:=TRUE; + end + else + exist:=FALSE; +end; + +{*------------------------------------------------------------------------*} + +var temp,infile,filename:string; + fp:file; + i,p:integer; + c:char; + zoo_temp,zoo_tag:longint; + numread:word; +begin + {* The start of the program. Everything in the program + * executes from here. Returns to DOS with ERRORLEVEL of 0 on + * successful completion. + *} + + if paramcount=0 then usage; {* check if no arguments entered *} + + temp:=paramstr(1); + for i:=1 to length(temp) do + case temp[i] of + '/':temp[i]:='\'; + else + temp[i]:=upcase(temp[i]); + end; + infile:=''; + if pos(':',temp)=0 then begin {* add drive to filename if not there *} + getdir(0,infile); + infile[0]:=#2; + end; + infile:=infile+temp; + + if not exist(infile) then begin + temp:=infile; + i:=0; + repeat + infile:=temp+filext[i]; + inc(i); + until (exist(infile)) or (i=EXTS); + if i=EXTS then abend(errmsg[0]); + end; + + assign(fp,infile); + reset(fp,1); + + c:=getbyte(fp); {* determine type of archive *} + case c of + #$1a:filetype:=1; + 'P':begin + if getbyte(fp)<>'K' then abend(errmsg[5]); + filetype:=2; + end; + 'Z':begin + for i:=0 to 1 do + if getbyte(fp)<>'O' then abend(errmsg[5]); + filetype:=3; + end; + else + abend(errmsg[5]); + end; + + reset(fp,1); {* back to start of file *} + + p:=0; {* drop drive and pathname *} + for i:=1 to length(infile) do + if infile[i] in [':','\'] then p:=i; + filename:=copy(infile,p+1,length(infile)-p); + + writeln; + writeln('Archive '+infile+': (IFL TP 5.0 version by Eric Oman)'); + writeln; + + accum_csize:=0; accum_usize:=0; {* set accumulators to 0 *} + level:=0; files:=0; {* ditto with counters *} + + if filetype=3 then begin {* process initial ZOO file header *} + for i:=0 to 19 do {* skip header text *} + c:=getbyte(fp); + {* get tag value *} + blockread(fp,zoo_tag,4,numread); + if numread<>4 then abend(errmsg[2]); + if zoo_tag<>Z_TAG then abend(errmsg[5]); + {* get data start *} + blockread(fp,zoo_temp,4,numread); if numread<>4 then abend(errmsg[2]); + {$I-} seek(fp,zoo_temp); {$I+} + if ioresult<>0 then abend(errmsg[4]); + end; + + writeln(HEADER_1); {* print headings *} + writeln(HEADER_2); + case filetype of + 1:arc_proc(fp); {* process ARC entry *} + 2:zip_proc(fp); {* process ZIP entry *} + 3:zoo_proc(fp); {* process ZOO entry *} + end; + final; {* clean things up *} + close(fp); {* close file *} + halt(0); +end. diff --git a/init.pas b/init.pas new file mode 100644 index 0000000..087b098 --- /dev/null +++ b/init.pas @@ -0,0 +1,1311 @@ +(*****************************************************************************) +(*> <*) +(*> Telegard Bulletin Board System - Copyright 1988,89,90 by <*) +(*> Eric Oman, Martin Pollard, and Todd Bolitho - All rights reserved. <*) +(*> <*) +(*> Program name: INIT.PAS <*) +(*> Program purpose: Initialization program for new systems <*) +(*> <*) +(*****************************************************************************) +program init; + +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +{$M 50000,0,1024} { Declared here suffices for all Units as well! } + +uses + crt, dos, + myio, timejunk; + +{$I rec25.pas} + +var + systatf:file of systatrec; + systat:systatrec; + modemf:file of modemrec; + modemr:modemrec; + fstringf:file of fstringrec; + fstring:fstringrec; + uf:file of userrec; + u:userrec; + sf:file of smalrec; + sr:smalrec; + bf:file of boardrec; + br:boardrec; + uff:file of ulrec; + ufr:ulrec; + xp:file of protrec; + xpr:protrec; + zf:file of zlogrec; + zfr:zlogrec; + brdf:file; + mixf:file; + tref:file; +(* mailfile:file of mailrec; + mr:mailrec;*) + lcallf:file of lcallers; + lcall:lcallers; + tfilf:file of tfilerec; + tfil:tfilerec; + verbf:file of verbrec; + vr:verbrec; + vdata:file of vdatar; + vd:vdatar; + smf:file of smr; + sm:smr; + ulff:file of ulfrec; + ulffr:ulfrec; + evf:file of eventrec; + evr:eventrec; + macrf:file of macrorec; + macr:macrorec; + fidorf:file of fidorec; + fidor:fidorec; + + curdir:string; + path:array[1..8] of string; + found:boolean; + dirinfo:searchrec; + i,j,k:integer; + c:char; + +function syn(b:boolean):astr; +begin + if (b) then syn:='Yes' else syn:='No '; +end; + +function yn:boolean; +var c:char; + b:boolean; +begin + repeat c:=upcase(readkey) until c in ['Y','N',^M]; + case c of 'Y':b:=TRUE; else b:=FALSE; end; + write(syn(b)); + yn:=b; +end; + +function pynq(s:string):boolean; +begin + textcolor(4); write(s); + textcolor(11); pynq:=yn; +end; + +procedure prt(s:string); +begin + textcolor(9); write(s); +end; + +procedure star(s:string); +begin + textcolor(9); write('þ '); + textcolor(11); cwrite(s); writeln; +end; + +function freek(d:integer):longint; +var lng:longint; +begin + lng:=diskfree(d); + freek:=lng div 1024; +end; + +function exdrv(s:astr):byte; +begin + s:=fexpand(s); + exdrv:=ord(s[1])-64; +end; + +function leapyear(yr:integer):boolean; +begin + leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0)); +end; + +function value(s:astr):longint; +var i,j:integer; +begin + val(s,i,j); + if (j<>0) then begin + s:=copy(s,1,j-1); + val(s,i,j) + end; + value:=i; + if (s='') then value:=0; +end; + +function days(mo,yr:integer):integer; +var d:integer; +begin + d:=value(copy('312831303130313130313031',1+(mo-1)*2,2)); + if ((mo=2) and (leapyear(yr))) then inc(d); + days:=d; +end; + +function daycount(mo,yr:integer):integer; +var m,t:integer; +begin + t:=0; + for m:=1 to (mo-1) do t:=t+days(m,yr); + daycount:=t; +end; + +function daynum(dt:astr):integer; +var d,m,y,t,c:integer; +begin + t:=0; + m:=value(copy(dt,1,2)); + d:=value(copy(dt,4,2)); + y:=value(copy(dt,7,2))+1900; + for c:=1985 to y-1 do + if (leapyear(c)) then inc(t,366) else inc(t,365); + t:=t+daycount(m,y)+(d-1); + daynum:=t; + if y<1985 then daynum:=0; +end; + +function tch(s:astr):astr; +begin + if (length(s)>2) then s:=copy(s,length(s)-1,2) else + if (length(s)=1) then s:='0'+s; + tch:=s; +end; + +function time:astr; +var h,m,s:string[3]; + hh,mm,ss,ss100:word; +begin + gettime(hh,mm,ss,ss100); + str(hh,h); str(mm,m); str(ss,s); + time:=tch(h)+':'+tch(m)+':'+tch(s); +end; + +function date:astr; +var r:registers; + y,m,d:string[3]; + yy,mm,dd,dow:word; +begin + getdate(yy,mm,dd,dow); + str(yy-1900,y); str(mm,m); str(dd,d); + date:=tch(m)+'/'+tch(d)+'/'+tch(y); +end; + +procedure ttl(s:string); +begin + writeln; + textcolor(9); write('ÄÄ['); + textbackground(1); textcolor(15); + write(' '+s+' '); + textbackground(0); textcolor(9); + write(']'); + repeat write('Ä') until wherex=80; + writeln; +end; + +(* FIX THIS UP *) +procedure movefile(var ok,nospace:boolean; showprog:boolean; + srcname,destname:astr); +var buffer:array[1..16384] of byte; + fs,dfs:longint; + nrec,i:integer; + src,dest:file; + + procedure dodate; + var r:registers; + od,ot,ha:integer; + begin + srcname:=srcname+#0; + destname:=destname+#0; + with r do begin + ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5700; msdos(dos.registers(r)); + od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(dos.registers(r)); + ax:=$3d02; ds:=seg(destname[1]); dx:=ofs(destname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(dos.registers(r)); + ax:=$3e00; bx:=ha; msdos(dos.registers(r)); + end; + end; + +begin + ok:=TRUE; nospace:=FALSE; + assign(src,srcname); + {$I-} reset(src,1); {$I+} + if (ioresult<>0) then begin ok:=FALSE; exit; end; + dfs:=freek(exdrv(destname)); + fs:=trunc(filesize(src)/1024.0)+1; + if (fs>=dfs) then begin + close(src); + nospace:=TRUE; ok:=FALSE; + exit; + end else begin + assign(dest,destname); + {$I-} rewrite(dest,1); {$I+} + if (ioresult<>0) then begin ok:=FALSE; exit; end; + repeat + blockread(src,buffer,16384,nrec); + blockwrite(dest,buffer,nrec); + until (nrec<16384); + close(dest); close(src); + dodate; + erase(src); + end; +end; + +procedure ffile(fn:string); +begin + findfirst(fn,anyfile,dirinfo); + found:=(doserror=0); +end; + +procedure nfile; +begin + findnext(dirinfo); + found:=(doserror=0); +end; + +procedure movefile1(srcname,destpath:string); +var ps,ns,es:string; + ok,nospace:boolean; +begin + ok:=TRUE; nospace:=FALSE; + fsplit(srcname,ps,ns,es); + star(srcname+#3#9+' -- '+#3#11+destpath); + movefile(ok,nospace,FALSE,srcname,destpath+ns+es); + if (not ok) then + if (nospace) then + star('Move failed: Insufficient space!!'^G) + else + star('Move failed!!'^G); +end; + +procedure movefiles(srcname,destpath:string); +var ok,nospace:boolean; +begin + ffile(srcname); + while found do begin + movefile1(dirinfo.name,destpath); + nfile; + end; +end; + + +function make_path(s:string):boolean; +begin + while (copy(s,length(s),1)='\') do s:=copy(s,1,length(s)-1); + make_path:=TRUE; + {$I-} mkdir(fexpand(s)); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(s)+'"'^G^G); + make_path:=FALSE; + end; +end; + +procedure make_paths; +var s:string; +begin + for i:=1 to 7 do begin + while copy(path[i],length(path[i]),1)='\' do + path[i]:=copy(path[i],1,length(path[i])-1); + case i of 1:s:='GFILES'; 2:s:='MSGS'; 3:s:='MENUS'; 4:s:='TFILES'; + 5:s:='AFILES'; 6:s:='TRAP'; 7:s:='TEMP'; 8:s:='SWAP'; end; + star(s+' path ("'+fexpand(path[i])+'")'); + if (not make_path(path[i])) then halt(1); + path[i]:=path[i]+'\'; + end; +(* star('Creating EMAIL and GENERAL message paths'); + if (not make_path(path[2]+'EMAIL\')) then halt(1); + if (not make_path(path[2]+'GENERAL\')) then halt(1);*) + star('Creating SYSOP and MISC file paths'); + if (not make_path('DLS\')) then halt(1); + if (not make_path('DLS\SYSOP')) then halt(1); + if (not make_path('DLS\MISC')) then halt(1); + star('Creating TEMP 1, 2, and 3 file paths'); + if (not make_path(path[7]+'1\')) then halt(1); + if (not make_path(path[7]+'2\')) then halt(1); + if (not make_path(path[7]+'3\')) then halt(1); +end; + +procedure make_status_dat; +begin + with systat do begin + gfilepath:=path[1]; + msgpath:=path[2]; + menupath:=path[3]; + tfilepath:=path[4]; + afilepath:=path[5]; + trappath:=path[6]; + temppath:=path[7]; + + bbsname:='Telegard BBS'; + bbsphone:='000-000-0000'; + sysopname:='System Operator'; + maxusers:=9999; + lowtime:=0; hitime:=0; + dllowtime:=0; dlhitime:=0; + shuttlelog:=FALSE; + lock300:=FALSE; + sysoppw:='SYSOP'; + newuserpw:=''; + shuttlepw:='MATRIX'; + b300lowtime:=0; b300hitime:=0; + b300dllowtime:=0; b300dlhitime:=0; + closedsystem:=FALSE; + swapshell:=FALSE; + eventwarningtime:=60; + tfiledate:=date; + { with hmsg do begin ltr:='A'; number:=-32766; ext:=1; end; } + {* A-32767.1 is the "Greetings from Telegard" message *} + for i:=1 to 20 do res1[i]:=0; + + sop:='s255'; + csop:='s250'; + msop:='s199'; + fsop:='s230'; + spw:='s250'; + seepw:='s255'; + normpubpost:='s11'; + normprivpost:='s11'; + anonpubread:='s100'; + anonprivread:='s100'; + anonpubpost:='s100'; + anonprivpost:='s100'; + seeunval:='s50'; + dlunval:='s230'; + nodlratio:='s255'; + nopostratio:='s200'; + nofilepts:='s255'; + ulvalreq:='s21'; + for i:=1 to 100 do res2[i]:=0; + + maxprivpost:=20; + maxfback:=5; + maxpubpost:=20; + maxchat:=3; + maxwaiting:=15; + csmaxwaiting:=50; + maxlines:=120; + csmaxlines:=160; + maxlogontries:=4; + bsdelay:=20; + sysopcolor:=4; + usercolor:=3; + minspaceforpost:=10; + minspaceforupload:=100; + backsysoplogs:=7; + wfcblanktime:=0; + linelen:=80; + pagelen:=25; + for i:=1 to 18 do res3[i]:=0; + + specialfx:=TRUE; + fossil:=FALSE; + allowalias:=TRUE; + phonepw:=TRUE; + localsec:=FALSE; + localscreensec:=FALSE; + globaltrap:=FALSE; + autochatopen:=TRUE; + autominlogon:=TRUE; + bullinlogon:=TRUE; + lcallinlogon:=TRUE; + yourinfoinlogon:=TRUE; + multitask:=FALSE; + offhooklocallogon:=TRUE; + forcevoting:=FALSE; + compressbases:=FALSE; + searchdup:=FALSE; + slogtype:=0; + stripclog:=FALSE; + newapp:=1; + guestuser:=-1; + timeoutbell:=2; + timeout:=5; + usewfclogo:=TRUE; + useems:=FALSE; + usebios:=TRUE; + cgasnow:=FALSE; + for i:=1 to 16 do res4[i]:=0; + + for i:=1 to 5 do + with filearcinfo[i] do + case i of + 1:begin + active:=TRUE; + ext:='ZIP'; + listline:='/1'; + arcline:='PKZIP -aex @F @I'; + unarcline:='PKUNZIP @F @I'; + testline:='PKUNZIP -t @F'; + cmtline:='PKZIP -z @F'; + succlevel:=0; + end; + 2:begin + active:=FALSE; + ext:='ARC'; + listline:='/2'; + arcline:='PKPAK a @F @I'; + unarcline:='PKUNPAK @F @I'; + testline:='PKUNPAK -t @F'; + cmtline:='PKPAK x @F'; + succlevel:=0; + end; + 3:begin + active:=FALSE; + ext:='PAK'; + listline:='/2'; + arcline:='PAK a @F @I'; + unarcline:='PAK e @F @I'; + testline:='PAK t @F'; + cmtline:=''; + succlevel:=-1; + end; + 4:begin + active:=FALSE; + ext:='LZH'; + listline:='/4'; + arcline:='LHARC a @F @I'; + unarcline:='LHARC e @F @I'; + testline:='LHARC t @F'; + cmtline:=''; + succlevel:=0; + end; + 5:begin + active:=FALSE; + ext:='ZOO'; + listline:='/3'; + arcline:='ZOO aP: @F @I'; + unarcline:='ZOO x @F @I'; + testline:='ZOO xNd @F'; + cmtline:='ZOO cA @F'; + succlevel:=0; + end; + 6:begin + active:=FALSE; + ext:='DWC'; + listline:='DWC v @F'; + arcline:='DWC a @F @I'; + unarcline:='DWC x @F @I'; + testline:='DWC t @F'; + cmtline:=''; + succlevel:=0; + end; + end; + filearcinfo[6].ext:=''; + + filearccomment[1]:=bbsname+' '+bbsphone; + filearccomment[2]:=''; filearccomment[3]:=''; + + uldlratio:=TRUE; + fileptratio:=FALSE; + fileptcomp:=3; + fileptcompbasesize:=10; + ulrefund:=100; + tosysopdir:=0; + validateallfiles:=FALSE; + remdevice:='COM1'; + maxintemp:=500; + minresume:=100; + maxdbatch:=20; + maxubatch:=20; + for i:=1 to 30 do res5[i]:=0; + + newsl:=20; + newdsl:=20; + newar:=[]; + newac:=[rpostan,rvoting]; + newfp:=0; + autosl:=50; + autodsl:=50; + autoar:=[]; + autoac:=[]; + + allstartmenu:='MAIN'; + chatcfilter1:=''; + chatcfilter2:=''; + bulletprefix:='BULLET'; + for i:=1 to 15 do res6[i]:=0; + + for i:=0 to 255 do begin + case i of 0..9:k:=1; 10..19:k:=10; 20..29:k:=20; 30..39:k:=40; + 40..49:k:=50; 50..59:k:=80; 60..69:k:=90; 70..79:k:=100; + 80..89:k:=110; 90..99:k:=120; 100..199:k:=130; + 200..239:k:=150; 240..249:k:=200; 250:k:=250; + 251..255:k:=6000; end; timeallow[i]:=k; + case i of 200..255:k:=20; 100..199:k:=15; 50..99:k:=10; + 30..49:k:=5; 20..29:k:=3; else k:=1; end; callallow[i]:=k; + case i of 60..255:k:=5; 20..59:k:=3; else k:=2; end; dlratio[i]:=k; + case i of 60..255:k:=10; 20..59:k:=5; else k:=2; end; dlkratio[i]:=k; + postratio[i]:=100; + end; + + lastdate:=date; + curwindow:=1; + istopwindow:=FALSE; + callernum:=0; + numusers:=1; + + with todayzlog do begin + for i:=0 to 4 do userbaud[i]:=0; + active:=0; calls:=0; newusers:=0; pubpost:=0; + privpost:=0; fback:=0; criterr:=0; + uploads:=0; downloads:=0; + uk:=0; dk:=0; + end; + + postcredits:=0; + rebootforevent:=FALSE; + watchdogdoor:=FALSE; + + windowon:=TRUE; + swappath:=path[8]; + for i:=1 to 119 do res[i]:=0; + end; + assign(systatf,'status.dat'); + rewrite(systatf); write(systatf,systat); close(systatf); +end; + +procedure make_fidonet_dat; +begin + with fidor do begin + zone:=0; + net:=0; + node:=0; + point:=0; + origin:=copy(systat.bbsname+' ('+systat.bbsphone+')',1,50); + text_color:=1; + quote_color:=3; + tear_color:=9; + origin_color:=5; + skludge:=TRUE; + sseenby:=TRUE; + sorigin:=FALSE; + scenter:=TRUE; + sbox:=TRUE; + mcenter:=TRUE; + addtear:=TRUE; + end; + assign(fidorf,'fidonet.dat'); + rewrite(fidorf); write(fidorf,fidor); close(fidorf); +end; + +procedure make_modem_dat; +var i,j:integer; +begin + with modemr do begin + waitbaud:=1200; + comport:=1; + init:='ATH0Q0V0E0M0X1S0=0S2=43S10=40&C1'; + answer:='ATA'; + hangup:='~~~+++~~~ATH0'; + offhook:='ATH1M0'; + nocallinittime:=30; + arq9600rate:=9600; + noforcerate:=FALSE; + nocarrier:=3; + nodialtone:=6; + busy:=7; + for i:=1 to 2 do + for j:=0 to 4 do begin + case i of + 1:case j of 0:k:=1; 1:k:=5; 2:k:=10; 3:k:=0; 4:k:=13; end; + 2:case j of 0:k:=0; 1:k:=15; 2:k:=16; 3:k:=0; 4:k:=17; end; + end; + resultcode[i][j]:=k; + end; + modemr.ctschecking:=TRUE; + modemr.dsrchecking:=TRUE; + modemr.usexonxoff:=FALSE; + modemr.hardwired:=FALSE; + end; + assign(modemf,'modem.dat'); + rewrite(modemf); write(modemf,modemr); close(modemf); +end; + +procedure make_string_dat; +begin + with fstring do begin + ansiq:='Display ANSI logon? '; + note[1]:='Enter your Telegard NAME or USER NUMBER'; + note[2]:='* NEW USERS, enter "NEW" *'; + lprompt:='Logon : '; + echoc:='X'; + sysopin:='^3The SysOp is probably around!'; + sysopout:='^3The SysOp is NOT here, or doesn''t want to chat'; + engage:='@M^3The SysOp brings you into chat!'; + endchat:='^3The SysOp returns you to the BBS....@M'; + wait:='^3{-^9Please Wait^3-}'; + pause:='(* pause *)'; + entermsg1:='Enter message now. You have ^3@X^1 lines maximum.'; + entermsg2:='Enter ^3/S^1 to save. ^3/?^1 for a list of commands.'; + newscan1:='^7[^5@Y ^7- ^5@W msgs^7] ^4NewScan began.@M'; + newscan2:='^7[^5@Y ^7- ^5@W msgs^7] ^4NewScan complete.@M'; + scanmessage:='^3[^1@Y^3]@M^5[@U] ^4Read (1-@W,,?=help) : '; + automsgt:='^5AutoMessage by: '; + autom:='-'; + + shelldos1:=#3#5+'>> '+systat.sysopname+' has shelled to DOS, please wait ...'; + shelldos2:=#3#5+'>> Thank you for waiting'; + chatcall1:=#3#0+'Paging '+systat.sysopname+' for chat, please wait.....'; + chatcall2:=#3#7+' >>'+#3#5+'<'+#3#8+'*'+#3#5+'>'+#3#7+'<<'; + guestline:='Enter "GUEST" as your user name to be a guest user on the system.'; + namenotfound:=#3#5+'That name is'+#3#8+' NOT'+#3#5+' found in the user list.'; + bulletinline:=#3#4+'Enter Bulletin Selection (XX,?,Q=Quit) : '; + thanxvote:=#3#3+'Thanks for taking the time to vote!'; + + listline:='List files - P to Pause'; + newline:='Search for new files -'; + searchline:='Search all directories for a file mask -'; + findline1:='Search descriptions and filenames for keyword -'; + findline2:='Enter the string to search for:'; + downloadline:='Download - You have @P file points.'; + uploadline:='Upload - @Kk free on this drive'; + viewline:='View archive interior files -@MP to Pause, N for Next file'; + nofilepts:=#3#8+'Access denied: '+#3#5+'Insufficient file points to download.'; + unbalance:=#3#8+'Access denied: '+#3#5+'Your upload/download ratio is out of balance:'; + + pninfo:='P to Pause, N for next directory'; + gfnline1:='[Enter]=All files'; + gfnline2:=#3#4+'File mask: '; + batchadd:='File added to batch queue.'; + end; + assign(fstringf,'string.dat'); + rewrite(fstringf); write(fstringf,fstring); close(fstringf); +end; + +procedure make_user_lst; +const dcols:clrs=((15,7,7,15,15,15,112,7,143,7),(15,7,1,11,9,14,31,4,140,10)); +begin + with u do begin + name:='SYSOP'; + realname:='System Operator'; + pw:='SYSOP'; + ph:='000-000-0000'; + bday:='00/00/00'; + firston:=date; + laston:=date; + street:=''; + citystate:=''; + zipcode:=''; + computer:='IBM Compatible'; + occupation:=''; + wherebbs:=''; + note:='Change these stats to yours.'; + lockedout:=FALSE; + deleted:=FALSE; + lockedfile:=''; + ac:=[onekey,pause,novice,ansi,color, + smw, {* short message waiting, in SHORTMSG.DAT *} + fnodlratio,fnopostratio,fnofilepts,fnodeletion]; + ar:=[]; for c:='A' to 'Z' do ar:=ar+[c]; +(* with qscan[1] do begin ltr:='A'; number:=-32767; ext:=1; end;*) +(* for i:=2 to maxboards do qscan[i]:=qscan[1];*) +(* for i:=1 to maxboards do qscn[i]:=TRUE;*) +(* dlnscn:=[];*) +(* for i:=0 to maxuboards do dlnscn:=dlnscn+[i];*) + for i:=1 to 20 do vote[i]:=0; + sex:='M'; + ttimeon:=0; + uk:=0; + dk:=0; + uploads:=0; + downloads:=0; + loggedon:=0; + tltoday:=600; + msgpost:=0; + emailsent:=0; + feedback:=0; + forusr:=0; + filepoints:=0; + waiting:=1; {* A-32767.1 -- "Greetings from Telegard" message *} + linelen:=80; + pagelen:=20; {* to make room for SysOp window when on.. *} + ontoday:=0; + illegal:=0; + sl:=255; + dsl:=255; + cols:=dcols; + lastmsg:=1; + lastfil:=0; + credit:=0; + timebank:=0; + for i:=1 to 5 do boardsysop[i]:=255; + trapactivity:=FALSE; + trapseperate:=FALSE; + timebankadd:=0; + mpointer:=-1; + chatauto:=FALSE; + chatseperate:=FALSE; + userstartmenu:=''; + slogseperate:=FALSE; + +{* NEW STUFF *} + + clsmsg:=2; { clear screen before displaying each message } + flistopt:=1; { use file listing option #1 (normal) } + msgorder:=0; { use Chrono message ordering } + avadjust:=1; { no AVATAR color adjustment } + +{* NEW STUFF *ENDS* *} + + for i:=1 to 54 do res[i]:=0; + end; + assign(uf,'user.lst'); + rewrite(uf); + seek(uf,0); write(uf,u); { write dummy record } + seek(uf,1); write(uf,u); { write user #1 } + close(uf); +end; + +procedure make_names_lst; +begin + with sr do begin + name:='SYSOP'; + number:=1; + end; + assign(sf,'names.lst'); + rewrite(sf); + seek(sf,0); write(sf,sr); + seek(sf,1); write(sf,sr); {* think that was the bug... time will tell *} + close(sf); +end; + +procedure make_macro_lst; +var i:integer; +begin + with macr do + for i:=1 to 4 do macro[i]:=''; + assign(macrf,'macro.lst'); + rewrite(macrf); + seek(macrf,0); write(macrf,macr); + close(macrf); +end; + +procedure make_boards_dat; +begin + with br do begin + name:='General Messages'; + filename:='GENERAL'; + msgpath:=''; + acs:=''; + postacs:='vv'; + mciacs:='%'; + maxmsgs:=50; + anonymous:=atno; + password:=''; + mbstat:=[mbskludge,mbsseenby,mbscenter,mbsbox,mbmcenter,mbaddtear]; + permindx:=0; + mbtype:=1; + origin:=fidor.origin; + text_color:=fidor.text_color; + quote_color:=fidor.quote_color; + tear_color:=fidor.tear_color; + origin_color:=fidor.origin_color; + for i:=1 to 11 do res[i]:=0; + end; + assign(bf,'boards.dat'); + rewrite(bf); write(bf,br); close(bf); +end; + +procedure make_uploads_dat; +begin + assign(uff,'uploads.dat'); + rewrite(uff); + with ufr do begin + name:='SysOp directory'; + filename:='SYSOP'; + dlpath:=curdir+'\DLS\SYSOP\'; + ulpath:=dlpath; + maxfiles:=2000; + password:=''; + arctype:=1; + cmttype:=1; + fbdepth:=0; + fbstat:=[]; + acs:='s255d255'; + ulacs:=''; + nameacs:='s255'; + permindx:=0; + for i:=1 to 6 do res[i]:=0; + end; + write(uff,ufr); + with ufr do begin + name:='Miscellaneous'; + filename:='MISC'; + dlpath:=curdir+'\DLS\MISC\'; + ulpath:=dlpath; + maxfiles:=2000; + password:=''; + arctype:=1; + cmttype:=1; + fbdepth:=0; + fbstat:=[]; + acs:='d30'; + ulacs:=''; + nameacs:=''; + permindx:=1; + for i:=1 to 6 do res[i]:=0; + end; + write(uff,ufr); close(uff); +end; + +procedure make_zlog_dat; +var i:integer; +begin + with zfr do begin + date:='08/18/89'; + for i:=0 to 4 do userbaud[i]:=0; + active:=0; calls:=0; newusers:=0; pubpost:=0; privpost:=0; + fback:=0; criterr:=0; + uploads:=0; downloads:=0; + uk:=0; dk:=0; + end; + assign(zf,'zlog.dat'); + rewrite(zf); write(zf,zfr); + zfr.date:=''; write(zf,zfr); + close(zf); +end; + +procedure blockwritestr(var f:file; s:string); +begin + blockwrite(f,s[0],1); + blockwrite(f,s[1],ord(s[0])); +end; + +procedure savemhead1(var brdf:file; mhead:mheaderrec); + + procedure outftinfo(var ft:fromtoinfo); + var s:string; + begin + with ft do begin + blockwrite(brdf,anon,1); + blockwrite(brdf,usernum,2); + blockwritestr(brdf,as); + blockwritestr(brdf,real); + blockwritestr(brdf,alias); + end; + end; + +begin +{rcg11172000 this is fooked.} +{ + with mhead do begin + blockwrite(brdf,signature,4); + blockwrite(brdf,msgptr,4); + blockwrite(brdf,isreplyto_iddate,6); + blockwrite(brdf,isreplyto_idrand,2); + blockwritestr(brdf,title); + outftinfo(fromi); + outftinfo(toi); + blockwritestr(brdf,originsite); + end; +} + + writeln('STUB: init.pas; savemhead1()...'); +end; + +procedure make_email_brd; +var t:text; + fb:file; + mheader:mheaderrec; + mixr:msgindexrec; + s:string; + dt:ldatetimerec; + pdt:packdatetime; + lng,lsize:longint; + i:integer; + bb:byte; + year,month,day,dow,hour,min,sec,sec100:word; +begin + assign(fb,'tosysop.ltr'); reset(fb,1); lsize:=filesize(fb); close(fb); + assign(t,'tosysop.ltr'); reset(t); + + assign(brdf,'email.brd'); + rewrite(brdf,1); + lng:=$FC020010; blockwrite(brdf,lng,4); + lng:=$DCBA0123; blockwrite(brdf,lng,4); + blockwrite(brdf,lsize,4); + + while (not eof(t)) do begin + readln(t,s); + bb:=$FF; blockwrite(brdf,bb,1); + blockwrite(brdf,s[0],1); + blockwrite(brdf,s[1],ord(s[0])); + end; + close(t); + erase(t); + + with mixr do begin + messagenum:=1; + hdrptr:=filesize(brdf); + msgindexstat:=[miexist]; + msgid:=4242; + + getdate(year,month,day,dow); + dt.year:=year; dt.month:=month; dt.day:=day; + gettime(hour,min,sec,sec100); + dt.hour:=hour; dt.min:=min; dt.sec:=sec; dt.sec100:=sec100; + dt2pdt(dt,pdt); + for i:=1 to 6 do msgdate[i]:=pdt[i]; + msgdowk:=0; + + {rcg11172000 fooked.} + { + for i:=1 to 6 do lastdate[i]:=pdt[i]; + lastdowk:=0; + } + writeln('STUB: init.pas; make_email_brd()...'); + + isreplyto:=65535; + numreplys:=0; + end; + + assign(mixf,'email.mix'); + rewrite(mixf,sizeof(mixr)); blockwrite(mixf,mixr,1); close(mixf); + with mheader do begin + signature:=$ABCD0123; + msgptr:=4; + {rcg11172000 fooked.} + { + for i:=1 to 6 do isreplyto_iddate[i]:=0; + isreplyto_idrand:=0; + } + writeln('STUB: init.pas; make_email_brd()...'); + title:='Greetings, new Telegard SysOp!!'; + with fromi do begin + anon:=0; + usernum:=1; + as:='The Telegard Team'; + real:='The Telegard Team'; + alias:='The Telegard Team'; + end; + with toi do begin + anon:=0; + usernum:=1; + as:='SysOp #1'; + real:='System Operator'; + alias:='SysOp'; + end; + + {rcg11172000 fooked.} + {originsite:='';} + writeln('STUB: init.pas; make_email_brd()...'); + + end; + savemhead1(brdf,mheader); + close(brdf); +end; + +procedure make_events_dat; +begin + assign(evf,'events.dat'); rewrite(evf); + with evr do begin + active:=TRUE; (* event is active *) + description:='Pack message bases'; + etype:='P'; (* PACK BASES event type *) + execdata:=''; (* no exec data needed *) + busytime:=0; (* no offhook before event *) + exectime:=240; (* 240 mins past midnite -- i.e. 4:00a *) + busyduring:=TRUE; (* take phone offhook during *) + duration:=1; (* 1 minute long *) + execdays:=127; (* every day of the week *) + monthly:=FALSE; (* weekly, not monthly *) + end; + write(evf,evr); + with evr do begin + active:=FALSE; (* event is NOT active *) + description:='Nightly events'; + etype:='D'; (* DOS SHELL event type *) + execdata:='night.bat'; (* call NIGHT.BAT *) + busytime:=1; (* take phone offhook 1 min before *) + exectime:=241; (* 241 mins past midnite -- i.e. 4:01a *) + busyduring:=TRUE; (* take phone offhook during *) + duration:=1; (* 1 minute long *) + execdays:=127; (* every day of the week *) + monthly:=FALSE; (* weekly, not monthly *) + end; + write(evf,evr); close(evf); +end; + +procedure make_laston_dat; +begin + with lcall do begin + callernum:=0; + name:='The Telegard Team'; + number:=0; + citystate:='Telegard Development HQ, MI'; + end; + assign(lcallf,'laston.dat'); + rewrite(lcallf); write(lcallf,lcall); + lcall.callernum:=-1; + for i:=1 to 9 do write(lcallf,lcall); + close(lcallf); +end; + +procedure make_gfiles_dat; +begin + assign(tfilf,'gfiles.dat'); + rewrite(tfilf); + for i:=0 to 1 do begin + with tfil do + case i of + 0:begin + title:=''; + filen:=''; + gdate:=date; + gdaten:=1; + acs:=''; + ulacs:=''; + tbstat:=[]; + permindx:=0; + tbdepth:=0; + for j:=1 to 4 do res[j]:=0; + end; + 1:begin + title:='Miscellaneous'; + filen:=#1#0#0#0#0#0; + gdate:=date; + gdaten:=daynum(gdate); + acs:=''; + ulacs:=''; + tbstat:=[]; + permindx:=0; + tbdepth:=0; + for j:=1 to 4 do res[j]:=0; + end; + end; + write(tfilf,tfil); + end; + close(tfilf); +end; + +procedure make_verbose_dat; +begin + with vr do + for i:=1 to 4 do descr[i]:=''; + assign(verbf,'verbose.dat'); + rewrite(verbf); write(verbf,vr); close(verbf); +end; + +procedure make_voting_dat; +begin + with vd do begin + question:='<< No Question >>'; + numa:=0; + for i:=0 to 9 do + with answ[i] do begin + if (i<>0) then ans:='Selection '+chr(i+48) else ans:='No Comment'; + numres:=0; + end; + end; + assign(vdata,'voting.dat'); + rewrite(vdata); + for i:=0 to 19 do write(vdata,vd); + close(vdata); +end; + +procedure make_shortmsg_dat; +begin + with sm do begin + msg:='Telegard system initialized on '+date+' at '+time+'.'; + destin:=1; + end; + assign(smf,'shortmsg.dat'); + rewrite(smf); write(smf,sm); close(smf); +end; + +procedure make_mboard(s:string); +var f:file; + mixr:msgindexrec; + lng:longint; + i:integer; +begin + assign(brdf,s+'.brd'); + rewrite(brdf,1); lng:=$FC020010; blockwrite(brdf,lng,4); close(brdf); + + assign(mixf,s+'.mix'); + rewrite(mixf,sizeof(mixr)); + mixr.hdrptr:=0; for i:=0 to 99 do blockwrite(mixf,mixr,1); + close(mixf); + + {rcg11172000 fooked.} + { + assign(tref,s+'.tre'); rewrite(tref,sizeof(mtreerec)); close(tref); + } + writeln('STUB: init.pas; make_mboard()...'); +end; + +procedure make_fboard(s:string); +begin + ulffr.blocks:=0; + assign(ulff,s+'.DIR'); + rewrite(ulff); write(ulff,ulffr); close(ulff); +end; + +procedure dostuff; +begin + ttl('Creating Telegard directory paths'); + make_paths; + ttl('Creating Telegard data files'); + make_status_dat; + make_modem_dat; + make_string_dat; + make_fidonet_dat; + make_user_lst; + make_names_lst; + make_macro_lst; + make_boards_dat; + make_uploads_dat; +(* make_protocol_dat;*) + make_zlog_dat; + make_email_brd; + make_events_dat; + make_laston_dat; + make_gfiles_dat; + make_verbose_dat; + make_voting_dat; + make_shortmsg_dat; + make_mboard('general'); + make_fboard('sysop'); + make_fboard('misc'); + + ttl('Moving data files into GFILES directory'); + movefile1('user.lst',path[1]); + movefile1('names.lst',path[1]); + movefile1('macro.lst',path[1]); + movefile1('boards.dat',path[1]); + movefile1('events.dat',path[1]); + movefile1('fidonet.dat',path[1]); + movefile1('gfiles.dat',path[1]); + movefile1('laston.dat',path[1]); + movefile1('modem.dat',path[1]); + movefile1('protocol.dat',path[1]); + movefile1('shortmsg.dat',path[1]); + movefile1('string.dat',path[1]); + movefile1('uploads.dat',path[1]); + movefile1('verbose.dat',path[1]); + movefile1('voting.dat',path[1]); + movefile1('zlog.dat',path[1]); + movefiles('*.DIR',path[1]); + + ttl('Moving message files into MSGS directory'); + movefile1('email.brd',path[2]); + movefile1('email.mix',path[2]); + movefile1('general.brd',path[2]); + movefile1('general.mix',path[2]); + movefile1('general.tre',path[2]); + + ttl('Moving ANSI text files into AFILES directory'); + movefiles('*.ANS',path[5]); + + ttl('Moving normal text files into AFILES directory'); + movefiles('*.MSG',path[5]); + movefile1('computer.txt',path[5]); + + ttl('Moving color configuration files into AFILES directory'); + movefiles('*.CFG',path[5]); + +(* ttl('Moving message file into MSGS\EMAIL directory'); + movefile1('a-32767.1',path[2]+'EMAIL\');*) + + ttl('Moving menu files into MENUS directory'); + movefiles('*.MNU',path[3]); +end; + +begin + infield_out_fgrd:=11; + infield_out_bkgd:=0; + infield_inp_fgrd:=15; + infield_inp_bkgd:=1; + clrscr; textbackground(1); textcolor(15); + gotoxy(1,1); clreol; gotoxy(10,1); + write('Telegard v'+ver+' Initialization Utility - Copyright 1988,89,90 by'); + gotoxy(1,2); clreol; gotoxy(8,2); + write('Eric Oman, Martin Pollard, and Todd Bolitho - All Rights Reserved.'); + textbackground(0); textcolor(7); + window(1,3,80,25); + writeln; + assign(systatf,'status.dat'); + {$I-} reset(systatf); {$I+} + if ioresult=0 then begin + textcolor(28); write('WARNING!!'); + textcolor(14); writeln(' "STATUS.DAT" file already exists..'); + writeln('Telegard has already been initialized!'); + writeln('If you proceed, ALL DATA FILES WILL BE ERASED AND INITIALIZED!!!'); + writeln; + if not pynq('Proceed? ') then halt(1); + writeln; + end; + + getdir(0,curdir); + path[1]:=curdir+'\GFILES\'; + path[2]:=curdir+'\MSGS\'; + path[3]:=curdir+'\MENUS\'; + path[4]:=curdir+'\TFILES\'; + path[5]:=curdir+'\AFILES\'; + path[6]:=curdir+'\TRAP\'; + path[7]:=curdir+'\TEMP\'; + path[8]:=curdir+'\SWAP\'; + + textcolor(14); + writeln; + writeln('You will now be prompted several times for names of directorys'); + writeln('that will be used by Telegard. Each directory will be created'); + writeln('and the appropriate files will be moved there-in.'); + writeln; + writeln('GFILES pathname. This is the directory where the Telegard data'); + writeln('files and miscellaneous Telegard text files will be located.'); + writeln; + prt('GFILES pathname: '); infielde(path[1],60); writeln; writeln; + + textcolor(14); + writeln('MSGS pathname. This directory should contain all the message'); + writeln('files (*.BRD, *.MIX, *.TRE) used by Telegard for both private'); + writeln('and public messages.'); + writeln; + prt('MSGS pathname: '); infielde(path[2],60); writeln; writeln; + + textcolor(14); + writeln('MENUS pathname. This is the directory where the Telegard menu'); + writeln('files will be located.'); + writeln; + prt('MENUS pathname: '); infielde(path[3],60); writeln; writeln; + + textcolor(14); + writeln('TFILES pathname. This is the directory where the Telegard'); + writeln('"text file section" text files will be located in.'); + writeln; + prt('TFILES pathname: '); infielde(path[4],60); writeln; writeln; + + textcolor(14); + writeln('AFILES pathname. This is the directory where the Telegard'); + writeln('menu help files, ANSI displays, etc. will be located.'); + writeln; + prt('AFILES pathname: '); infielde(path[5],60); writeln; writeln; + + textcolor(14); + writeln('TRAP pathname. This is the directory where Telegard will'); + writeln('output all User Audit traps, chat conversations (CHAT.MSG),'); + writeln('and SysOp logs (SYSOP*.LOG).'); + writeln; + prt('TRAP pathname: '); infielde(path[6],60); writeln; writeln; + + textcolor(14); + writeln('TEMP pathname. Telegard uses this directory to convert between'); + writeln('archive formats, receive batch uploads, and allow users to'); + writeln('decompress archives to download single files, etc.'); + writeln; + prt('TEMP pathname: '); infielde(path[7],60); writeln; writeln; + + textcolor(14); + writeln('SWAP pathname. This is the directory where Telegard''s swap'); + writeln('shell function will store its memory image file (if it cannot'); + writeln('swap to EMS memory).'); + writeln; + prt('SWAP pathname: '); infielde(path[8],60); writeln; writeln; + + clrscr; + + dostuff; + + writeln; + star('Telegard BBS installed and initialized successfully!'); + star('This program, "INIT.EXE", can now be deleted.'); + star('Thanks for trying Telegard!'); +end. diff --git a/init16d3.pas b/init16d3.pas new file mode 100644 index 0000000..b53c1f1 --- /dev/null +++ b/init16d3.pas @@ -0,0 +1,824 @@ +program init; + +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +{$M 50000,0,90000} { Declared here suffices for all Units as well! } + +uses + crt,dos, + myio, + common; + +{$I rec16d3.pas} + +var + systatf:file of systatrec; + systat:systatrec; + uf:file of userrec; + u:userrec; + sf:file of smalrec; + sr:smalrec; + bf:file of boardrec; + br:boardrec; + uff:file of ulrec; + ufr:ulrec; + xp:file of expro; + xpr:expro; + zf:file of zlogt; + zfr:zlogt; + mailfile:file of mailrec; + mr:mailrec; + lcallf:file of lcallers; + lcall:lcallers; + tfilf:file of gft; + tfil:gft; + verbf:file of verbrec; + vr:verbrec; + vdata:file of vdatar; + vd:vdatar; + smf:file of smr; + sm:smr; + msr:messagerec; + ulff:file of ulfrec; + ulffr:ulfrec; + + curdir:string; + path:array[1..5] of string; + found:boolean; + dirinfo:searchrec; + i,j,k:integer; + c:char; + +function yn:boolean; +var c:char; + b:boolean; +begin + repeat c:=upcase(readkey) until c in ['Y','N',^M]; + case c of 'Y':b:=TRUE; else b:=FALSE; end; + write(syn(b)); + yn:=b; +end; + +function pynq(s:string):boolean; +begin + textcolor(4); write(s); + textcolor(11); pynq:=yn; +end; + +procedure prt(s:string); +begin + textcolor(9); write(s); +end; + +procedure star(s:string); +begin + textcolor(9); write('þ '); + textcolor(11); writeln(s); +end; + +procedure ttl(s:string); +begin + writeln; + textcolor(9); write('ÄÄ['); + textbackground(1); textcolor(15); + write(' '+s+' '); + textbackground(0); textcolor(9); + write(']'); + repeat write('Ä') until wherex=80; + writeln; +end; + +procedure movefile(srcname,destpath:string); +var buffer:array[1..16384] of byte; + dfs,nrec:integer; + src,dest:file; + + procedure dodate; + var r:registers; + od,ot,ha:integer; + begin + srcname:=srcname+#0; + destpath:=destpath+#0; + with r do begin + ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5700; msdos(dos.registers(r)); + od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(dos.registers(r)); + ax:=$3d02; ds:=seg(destpath[1]); dx:=ofs(destpath[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(dos.registers(r)); + ax:=$3e00; bx:=ha; msdos(dos.registers(r)); + end; + end; + +begin + star('Moving "'+srcname+'" to "'+destpath+'"'); + destpath:=destpath+srcname; + assign(src,srcname); + {$I-} reset(src,1); {$I+} + if ioresult<>0 then begin + writeln; + star('"'+srcname+'": File not found.'^G^G); + halt(1); + end else begin + dfs:=freek(exdrv(destpath)); + + {rcg11172000 don't have LONGfilesize()...} + {if trunc(longfilesize(src)/1024.0)+1>=dfs then begin} + if trunc(filesize(src)/1024.0)+1>=dfs then begin + writeln; + star('"'+srcname+'": Disk full.'); + halt(1); + end else begin + assign(dest,destpath); rewrite(dest,1); + repeat + blockread(src,buffer,16384,nrec); + blockwrite(dest,buffer,nrec); + until (nrec<16384); + close(dest); + close(src); + dodate; + erase(src); + end; + end; +end; + +procedure ffile(fn:string); +begin + findfirst(fn,anyfile,dirinfo); + found:=(doserror=0); +end; + +procedure nfile; +begin + findnext(dirinfo); + found:=(doserror=0); +end; + +procedure movefiles(srcname,destpath:string); +begin + ffile(srcname); + while found do begin + movefile(dirinfo.name,destpath); + nfile; + end; +end; + + +procedure make_paths; +var s:string; +begin + for i:=1 to 4 do begin + while copy(path[i],length(path[i]),1)='\' do + path[i]:=copy(path[i],1,length(path[i])-1); + case i of 1:s:='GFILES'; 2:s:='MSGS'; 3:s:='MENUS'; 4:s:='TFILES'; end; + star(s+' path ("'+fexpand(path[i])+'")'); + {$I-} mkdir(fexpand(path[i])); {$I+} + if ioresult<>0 then begin + writeln; + star('Error creating directory "'+fexpand(path[i])+'"'); + halt(1); + end; + path[i]:=path[i]+'\'; + end; +end; + +procedure make_status_dat; +begin + with systat do begin + bbsname:='Telegard BBS'; + bbsphone:='000-000-0000'; + sysopfirst:='System'; + sysoplast:='Operator'; + boardpw:=''; + sysoppw:='SYSOP'; + bbspw:='MATRIX'; + closedsystem:=FALSE; + matrix:=FALSE; + alias:=TRUE; + clearmsg:=TRUE; + fone:=TRUE; + multitask:=FALSE; + bwindow:=TRUE; + lock300:=FALSE; + wantquote:=TRUE; {* /// *} + mcimsg:=TRUE; {* /// *} + special:=TRUE; + localsec:=FALSE; + autominlogon:=TRUE; + bullinlogon:=TRUE; + lcallinlogon:=TRUE; + autochatopen:=TRUE; + with hmsg do begin ltr:='A'; number:=-32766; ext:=1; end; + {* A-32767.1 is the "Greetings from Telegard" message *} + tfiledate:='04/21/89'; + lastdate:='04/21/89'; + users:=1; + callernum:=0; + activetoday:=0; + callstoday:=0; + msgposttoday:=0; + emailtoday:=0; + fbacktoday:=0; + uptoday:=0; + newuk:=0; + newusertoday:=0; + dntoday:=0; + newdk:=0; + gfilepath:=path[1]; + msgpath:=path[2]; + menupath:=path[3]; + tfilepath:=path[4]; + lowtime:=0; hitime:=0; + dllowtime:=0; dlhitime:=0; + b300lowtime:=0; b300hitime:=0; + b300dllowtime:=0; b300dlhitime:=0; + app:=1; + guestuser:=-1; + timeoutbell:=2; + timeout:=5; + sysopcolor:=4; usercolor:=3; + bsdelay:=20; + tosysopdir:=0; + for i:=1 to 9 do sysopmacro[i]:=''; + comport:=1; + maxbaud:=1200; + init:='ATH0Q0V0E0M0X1S0=0S2=1S10=40&C1'; + hangup:='ATH'; + offhook:='ATH1'; + answer:='ATA'; + for i:=1 to 2 do + for j:=0 to 4 do begin + case i of + 1:case j of 0:k:=1; 1:k:=5; 2:k:=10; 3:k:=0; 4:k:=13; end; + 2:case j of 0:k:=0; 1:k:=15; 2:k:=16; 3:k:=0; 4:k:=17; end; + end; + resultcode[i][j]:=k; + end; + nocarrier:=3; + nodialtone:=6; + busy:=7; + nocallinittime:=30; + tries:=4; + newsl:=20; newdsl:=20; + newar:=[]; + newac:=[rpostan,rvoting]; + newfp:=0; + autosl:=50; autodsl:=50; + autoar:=[]; + autoac:=[]; + ansiq:='Display ANSI logon? '; + engage:='@M^3The SysOp brings you into chat!'; + endchat:='^3The SysOp returns you to the BBS....@M'; + sysopin:='^3The SysOp is probably around!'; + sysopout:='^3The SysOp is NOT here, or doesn''t want to chat'; + note[1]:='Enter your Telegard NAME or USER NUMBER'; + note[2]:='* NEW USERS, enter "NEW" *'; + lprompt:='Logon : '; + wait:='^3{-^9Please Wait^3-}'; + pause:='(* pause *)'; + msg1:='Enter message now. You have ^3@X^1 lines maximum.'; + msg2:='Enter ^3/S^1 to save. ^3/?^1 for a list of commands.'; + new1:='^7[^5@Y ^7- ^5@W msgs^7] ^4NewScan began.@M'; + new2:='^7[^5@Y ^7- ^5@W msgs^7] ^4NewScan complete.@M'; + read:='^3[^1@Y^3]@M^5[@U] ^4Read (1-@W,,T,Q,P,A,R,B,W,D) : '; + auto1:='^5AutoMessage by: '; + autom:='-'; + echoc:='X'; + + uldlratio:=TRUE; + fileptratio:=FALSE; + fileptcomp:=3; + fileptcompbasesize:=10; + + for i:=0 to 255 do begin + case i of 0..9:k:=1; 10..19:k:=10; 20..29:k:=20; 30..39:k:=40; + 40..49:k:=50; 50..59:k:=80; 60..69:k:=90; 70..79:k:=100; + 80..89:k:=110; 90..99:k:=120; 100..199:k:=130; + 200..239:k:=150; 240..249:k:=200; 250:k:=250; + 251..255:k:=6000; end; timeallow[i]:=k; + case i of 200..255:k:=20; 100..199:k:=15; 50..99:k:=10; + 30..49:k:=5; 20..29:k:=3; else k:=1; end; callallow[i]:=k; + case i of 60..255:k:=5; 20..59:k:=3; else k:=2; end; dlratio[i]:=k; + case i of 60..255:k:=10; 20..59:k:=5; else k:=2; end; dlkratio[i]:=k; + postratio[i]:=100; + end; + + normpubpost:=11; anonpubpost:=100; anonpubread:=100; + normprivpost:=11; anonprivpost:=100; anonprivread:=100; + maxpubpost:=20; maxprivpost:=20; + maxfback:=5; maxchat:=3; + maxwaiting:=15; csmaxwaiting:=50; + maxlines:=120; csmaxlines:=160; + + sop:=255; csop:=250; + msop:=199; fsop:=230; + spw:=250; seepw:=255; + nodlratio:=255; nopostratio:=200; + nofilepts:=255; seeunval:=50; + dlunval:=230; ulrefund:=100; + + filearctype:=1; + filearccomment:=bbsname+' '+bbsphone; + + for i:=1 to 4 do + with filearcinfo[i] do + case i of + 1:begin + ext:='ZIP'; + listline:='/1'; + arcline:='PKZIP -aeb4 @F'; + unarcline:='PKUNZIP @F'; + testline:='PKUNZIP -t @F'; + cmtline:='PKZIP -z @F'; + succlevel:=0; + end; + 2:begin + ext:='ARC'; + listline:='/2'; + arcline:='PKPAK a @F'; + unarcline:='PKUNPAK @F'; + testline:='PKUNPAK -t @F'; + cmtline:='PKPAK x @F'; + succlevel:=0; + end; + 3:begin + ext:='ZOO'; + listline:='/3'; + arcline:='ZOO aP: @F *.*'; + unarcline:='ZOO x @F'; + testline:='ZOO xNd @F'; + cmtline:='ZOO cA @F'; + succlevel:=0; + end; + 4:begin + ext:='PAK'; + listline:='/2'; + arcline:='PAK a @F'; + unarcline:='PAK e @F'; + testline:=''; + cmtline:=''; + succlevel:=-1; + end; + end; + filearcinfo[5].ext:=''; + + yourinfoinlogon:=TRUE; + localscreensec:=FALSE; + globaltrap:=FALSE; + snowchecking:=FALSE; + + for i:=1 to 198 do res[i]:=0; + end; + assign(systatf,'status.dat'); + rewrite(systatf); write(systatf,systat); close(systatf); +end; + +procedure make_user_lst; +const dcols:clrs=((15,7,7,15,15,15,112,7,143,7),(15,3,1,11,9,14,31,4,140,10)); +begin + with u do begin + name:='SYSOP'; + realname:='System Operator'; + pw:='SYSOP'; + ph:='000-000-0000'; + firston:='04/21/89'; + laston:='04/21/89'; + street:=''; + citystate:=''; + zipcode:=''; + computer:='IBM Compatible'; + occupation:=''; + wherebbs:=''; + note:='Change these stats to yours.'; + lockedout:=FALSE; + deleted:=FALSE; + lockedfile:=''; + ac:=[onekey,wordwrap,pause,novice,ansi,color, + smw, {* short message waiting, in SHORTMSG.DAT *} + fnodlratio,fnopostratio,fnofilepts,fnodeletion]; + for c:='A' to 'G' do ar:=ar+[c]; + with qscan[1] do begin ltr:='A'; number:=-32767; ext:=1; end; + for i:=2 to maxboards do qscan[i]:=qscan[1]; + for i:=1 to maxboards do qscn[i]:=TRUE; + dlnscn:=[]; + for i:=0 to maxuboards do dlnscn:=dlnscn+[i]; + for i:=1 to 2 do macro[i]:=''; + for i:=1 to 20 do vote[i]:=0; + age:=99; + sex:='M'; + ttimeon:=0.0; + uk:=0.0; + dk:=0.0; + uploads:=0; + downloads:=0; + loggedon:=0; + tltoday:=600; + msgpost:=0; + emailsent:=0; + feedback:=0; + forusr:=0; + filepoints:=0; + waiting:=1; {* A-32767.1 -- "Greetings from Telegard" message *} + linelen:=80; + pagelen:=23; {* to make room for SysOp window when on.. *} + ontoday:=0; + illegal:=0; + sl:=255; + dsl:=255; + cols:=dcols; + lastmsg:=1; + lastfil:=0; + credit:=0.0; + timebank:=0; + for i:=1 to 5 do boardsysop[i]:=255; + +{* NEW STUFF *} + + trapactivity:=FALSE; + trapseperate:=FALSE; + +{* NEW STUFF *ENDS* *} + + for i:=1 to 70 do res[i]:=0; + end; + assign(uf,'user.lst'); + rewrite(uf); + seek(uf,0); write(uf,u); + seek(uf,1); write(uf,u); + close(uf); +end; + +procedure make_names_lst; +begin + with sr do begin + name:='SYSOP'; + number:=1; + end; + assign(sf,'names.lst'); + rewrite(sf); + seek(sf,0); write(sf,sr); + seek(sf,1); write(sf,sr); + close(sf); +end; + +procedure make_boards_dat; +begin + with br do begin + name:='General Messages'; + filename:='GENERAL'; + sl:=30; + maxmsgs:=50; + pw:=''; + anonymous:=no; + ar:='@'; + key:=#0; + postsl:=30; + end; + assign(bf,'boards.dat'); + rewrite(bf); + seek(bf,0); write(bf,br); + close(bf); +end; + +procedure make_uploads_dat; +begin + assign(uff,'uploads.dat'); + rewrite(uff); + with ufr do begin + name:='SysOp directory'; + filename:='SYSOP'; + dlpath:=curdir+'\DLOADS\SYSOP\'; + noratio:=FALSE; + sl:=255; + dsl:=255; + namesl:=255; + ar:='@'; + maxfiles:=999; + agereq:=1; + password:=''; + end; + write(uff,ufr); + with ufr do begin + name:='Miscellaneous'; + filename:='MISC'; + dlpath:=curdir+'\DLOADS\MISC\'; + noratio:=FALSE; + sl:=30; + dsl:=30; + namesl:=10; + ar:='@'; + maxfiles:=999; + agereq:=1; + password:=''; + end; + write(uff,ufr); close(uff); +end; + +procedure make_protocol_dat; +begin + assign(xp,'protocol.dat'); + rewrite(xp); + for i:=1 to 11 do + with xpr do begin + rcmd:=''; scmd:=''; + rul:=FALSE; rdl:=FALSE; + xferok:=-1; + case i of + 1:begin descr:='Ascii'; key:='A'; ptype:=1; rul:=TRUE; end; + 2:begin descr:='Xmodem'; key:='X'; ptype:=2; end; + 3:begin descr:='Xmodem CRC'; key:='C'; ptype:=3; end; + 4:begin descr:='Ymodem'; key:='Y'; ptype:=4; end; + 5:begin descr:='Ymodem'; key:='Y'; ptype:=5; rul:=TRUE; end; + 6:begin + descr:='Zmodem'; + key:='Z'; + ptype:=6; + rcmd:='dsz port @2 speed @1 rz @3'; + scmd:='dsz port @2 speed @1 sz @3'; + xferok:=0; + end; + 7:begin + descr:='Zmodem'; + key:='Z'; + ptype:=7; + rcmd:='dsz port @2 speed @1 rz'; + scmd:='dsz port @2 speed @1 @@4'; + xferok:=0; +rul:=TRUE; + end; + 8:begin + descr:='Lynx'; + key:='L'; + ptype:=6; + rcmd:='lynx R @3 /@2 /@1'; + scmd:='lynx S @3 /@2 /@1'; + xferok:=0; + end; + 9:begin + descr:='Lynx'; + key:='L'; + ptype:=7; + rcmd:='lynx R /@2 /@1'; + scmd:='lynx S /@2 /@1 @3'; + xferok:=0; +rul:=TRUE; + end; + 10:begin + descr:='Jmodem'; + key:='J'; + ptype:=6; + rcmd:='jmodem R@2 @3'; + scmd:='jmodem S@2 @3'; + xferok:=-1; + end; + 11:begin + descr:='Megalink'; + key:='M'; + ptype:=6; + rcmd:='mlink PORT @2 SPEED @1 RM @3'; + scmd:='mlink PORT @2 SPEED @1 SM @3'; + xferok:=0; + end; + end; + write(xp,xpr); + end; + close(xp); +end; + +procedure make_zlog_dat; +begin + with zfr do begin + date:='04/21/89'; + active:=0; + calls:=0; + post:=0; + email:=0; + fback:=0; + up:=0; + end; + assign(zf,'zlog.dat'); + rewrite(zf); write(zf,zfr); + zfr.date:=''; + for i:=1 to 96 do write(zf,zfr); + close(zf); +end; + +procedure make_email_dat; +begin + with mr do begin + title:='Greetings from Telegard'; + from:=1; destin:=1; + with msg do begin ltr:='A'; number:=-32767; ext:=1; end; + mage:=255; + end; + mr.date:=daynum(date); + assign(mailfile,'email.dat'); + rewrite(mailfile); write(mailfile,mr); close(mailfile); +end; + +procedure make_laston_dat; +begin + with lcall do begin + callernum:=0; + name:='Eric Oman'; + number:=1; + end; + assign(lcallf,'laston.dat'); + rewrite(lcallf); write(lcallf,lcall); + lcall.callernum:=-1; + for i:=1 to 9 do write(lcallf,lcall); + close(lcallf); +end; + +procedure make_gfiles_dat; +begin + assign(tfilf,'gfiles.dat'); + rewrite(tfilf); + for i:=0 to 1 do begin + with tfil do + case i of + 0:begin + num:=1; {* 1 entry total *} + title:=''; + filen:=''; + ar:='@'; + gdate:='04/21/89'; + gdaten:=daynum(gdate); + end; + 1:begin + num:=0; {* SL level *} + title:='Miscellaneous'; + filen:=#1#0#0#0#0#0; + ar:='@'; + gdate:='04/21/89'; + gdaten:=daynum(gdate); + end; + end; + write(tfilf,tfil); + end; + close(tfilf); +end; + +procedure make_verbose_dat; +begin + with vr do + for i:=1 to 4 do descr[i]:=''; + assign(verbf,'verbose.dat'); + rewrite(verbf); write(verbf,vr); close(verbf); +end; + +procedure make_voting_dat; +begin + with vd do begin + question:='<< No Question >>'; + numa:=0; + for i:=0 to 9 do + with answ[i] do begin + if i<>0 then ans:='Selection '+chr(i+48) else ans:='No Comment'; + numres:=0; + end; + end; + assign(vdata,'voting.dat'); + rewrite(vdata); + for i:=0 to 19 do write(vdata,vd); + close(vdata); +end; + +procedure make_shortmsg_dat; +begin + with sm do begin + msg:='Telegard files initialized on '+date+' '+time+'.'; + destin:=1; + end; + assign(smf,'shortmsg.dat'); + rewrite(smf); write(smf,sm); close(smf); +end; + +procedure make_mboard(s:string); +var f:file; +begin + msr.message.number:=0; + assign(f,s+'.BRD'); + rewrite(f,sizeof(messagerec)); blockwrite(f,msr,1); close(f); +end; + +procedure make_fboard(s:string); +begin + ulffr.blocks:=0; + assign(ulff,s+'.DIR'); + rewrite(ulff); write(ulff,ulffr); close(ulff); +end; + +procedure dostuff; +begin + ttl('Creating Telegard directory paths'); + make_paths; + ttl('Creating Telegard data files'); + make_status_dat; + make_user_lst; + make_names_lst; + make_boards_dat; + make_uploads_dat; + make_protocol_dat; + make_zlog_dat; + make_email_dat; + make_laston_dat; + make_gfiles_dat; + make_verbose_dat; + make_voting_dat; + make_shortmsg_dat; + make_mboard('general'); + make_fboard('sysop'); + make_fboard('misc'); + ttl('Moving data files into GFILES directory'); + movefile('user.lst',path[1]); + movefile('names.lst',path[1]); + movefile('boards.dat',path[1]); + movefile('email.dat',path[1]); + movefile('gfiles.dat',path[1]); + movefile('laston.dat',path[1]); + movefile('protocol.dat',path[1]); + movefile('shortmsg.dat',path[1]); + movefile('uploads.dat',path[1]); + movefile('verbose.dat',path[1]); + movefile('voting.dat',path[1]); + movefile('zlog.dat',path[1]); + movefiles('*.BRD',path[1]); + movefiles('*.DIR',path[1]); + ttl('Moving miscellaneous text files into GFILES directory'); + movefiles('*.ANS',path[1]); + movefiles('*.MSG',path[1]); + movefiles('*.TUT',path[1]); + movefile('computer.txt',path[1]); + ttl('Moving message file into MSGS directory'); + movefile('a-32767.1',path[2]); + ttl('Moving menu files into MENUS directory'); + movefiles('*.MNU',path[3]); +end; + +begin + infield_out_fgrd:=11; + infield_out_bkgd:=0; + infield_inp_fgrd:=15; + infield_inp_bkgd:=1; + + clrscr; + gotoxy(1,1); textbackground(1); textcolor(15); + clreol; write(' Initialization Utility for Telegard version '+ver); + textbackground(0); textcolor(7); + window(1,2,80,25); + writeln; + assign(systatf,'status.dat'); + {$I-} reset(systatf); {$I+} + if ioresult=0 then begin + textcolor(28); write('WARNING!!'); + textcolor(14); writeln(' "STATUS.DAT" file already exists..'); + writeln('Telegard has already been initialized!'); + writeln('If you proceed, ALL DATA FILES WILL BE ERASED AND INITIALIZED!!!'); + writeln; + if not pynq('Proceed? ') then halt(1); + writeln; + end; + + getdir(0,curdir); + path[1]:=curdir+'\GFILES\'; + path[2]:=curdir+'\MSGS\'; + path[3]:=curdir+'\MENUS\'; + path[4]:=curdir+'\TFILES\'; + + textcolor(14); + writeln; + writeln('You will now be prompted several times for names of directorys'); + writeln('that will be used by Telegard. Each directory will be created'); + writeln('and the appropriate files will be moved there-in.'); + writeln; + writeln('GFILES pathname. This is the directory where the Telegard data'); + writeln('files and miscellaneous Telegard text files will be located.'); + writeln; + prt('GFILES dirname: '); infielde(path[1],60); writeln; writeln; + + textcolor(14); + writeln('MSGS pathname. This is the directory where the Telegard message'); + writeln('files to be used in the message section will be located.'); + writeln; + prt('MSGS dirname: '); infielde(path[2],60); writeln; writeln; + + textcolor(14); + writeln('MENUS pathname. This is the directory where the Telegard menu'); + writeln('files will be located.'); + writeln; + prt('MENUS dirname: '); infielde(path[3],60); writeln; writeln; + + textcolor(14); + writeln('TFILES pathname. This is the directory where the Telegard'); + writeln('"text file section" text files will be located in.'); + writeln; + prt('TFILES dirname: '); infielde(path[4],60); writeln; writeln; + + clrscr; + + dostuff; + + writeln; + star('Telegard BBS installed and initialized successfully!'); + star('This program, "INIT.EXE", can now be deleted.'); + star('Thanks for trying Telegard!'); +end. diff --git a/init16e1.pas b/init16e1.pas new file mode 100644 index 0000000..56275d5 --- /dev/null +++ b/init16e1.pas @@ -0,0 +1,958 @@ +program init; + +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +{$M 50000,0,90000} { Declared here suffices for all Units as well! } + +uses + crt,dos, + myio, + common; + +{$I rec16e1.pas} + +var + systatf:file of systatrec; + systat:systatrec; + uf:file of userrec; + u:userrec; + sf:file of smalrec; + sr:smalrec; + bf:file of boardrec; + br:boardrec; + uff:file of ulrec; + ufr:ulrec; + xp:file of expro; + xpr:expro; + zf:file of zlogt; + zfr:zlogt; + mailfile:file of mailrec; + mr:mailrec; + lcallf:file of lcallers; + lcall:lcallers; + tfilf:file of gft; + tfil:gft; + verbf:file of verbrec; + vr:verbrec; + vdata:file of vdatar; + vd:vdatar; + smf:file of smr; + sm:smr; + msr:messagerec; + ulff:file of ulfrec; + ulffr:ulfrec; + evf:file of eventrec; + evr:eventrec; + macrf:file of macrorec; + macr:macrorec; + + curdir:string; + path:array[1..7] of string; + found:boolean; + dirinfo:searchrec; + i,j,k:integer; + c:char; + +function yn:boolean; +var c:char; + b:boolean; +begin + repeat c:=upcase(readkey) until c in ['Y','N',^M]; + case c of 'Y':b:=TRUE; else b:=FALSE; end; + write(syn(b)); + yn:=b; +end; + +function pynq(s:string):boolean; +begin + textcolor(4); write(s); + textcolor(11); pynq:=yn; +end; + +procedure prt(s:string); +begin + textcolor(9); write(s); +end; + +procedure star(s:string); +begin + textcolor(9); write('þ '); + textcolor(11); writeln(s); +end; + +procedure ttl(s:string); +begin + writeln; + textcolor(9); write('ÄÄ['); + textbackground(1); textcolor(15); + write(' '+s+' '); + textbackground(0); textcolor(9); + write(']'); + repeat write('Ä') until wherex=80; + writeln; +end; + +procedure movefile(srcname,destpath:string); +var buffer:array[1..16384] of byte; + dfs,nrec:integer; + src,dest:file; + + procedure dodate; + var r:registers; + od,ot,ha:integer; + begin + srcname:=srcname+#0; + destpath:=destpath+#0; + with r do begin + ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5700; msdos(dos.registers(r)); + od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(dos.registers(r)); + ax:=$3d02; ds:=seg(destpath[1]); dx:=ofs(destpath[1]); msdos(dos.registers(r)); + ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(dos.registers(r)); + ax:=$3e00; bx:=ha; msdos(dos.registers(r)); + end; + end; + +begin + star('Moving "'+srcname+'" to "'+destpath+'"'); + destpath:=destpath+srcname; + assign(src,srcname); + {$I-} reset(src,1); {$I+} + if ioresult<>0 then begin + writeln; + star('"'+srcname+'": File not found.'^G^G); + halt(1); + end else begin + dfs:=freek(exdrv(destpath)); + + {rcg11172000 don't have LONGfilesize()...} + {if trunc(longfilesize(src)/1024.0)+1>=dfs then begin} + if trunc(filesize(src)/1024.0)+1>=dfs then begin + writeln; + star('"'+srcname+'": Disk full.'); + halt(1); + end else begin + assign(dest,destpath); rewrite(dest,1); + repeat + blockread(src,buffer,16384,nrec); + blockwrite(dest,buffer,nrec); + until (nrec<16384); + close(dest); + close(src); + dodate; + erase(src); + end; + end; +end; + +procedure ffile(fn:string); +begin + findfirst(fn,anyfile,dirinfo); + found:=(doserror=0); +end; + +procedure nfile; +begin + findnext(dirinfo); + found:=(doserror=0); +end; + +procedure movefiles(srcname,destpath:string); +begin + ffile(srcname); + while found do begin + movefile(dirinfo.name,destpath); + nfile; + end; +end; + + +function make_path(s:string):boolean; +begin + while (copy(s,length(s),1)='\') do s:=copy(s,1,length(s)-1); + make_path:=TRUE; + {$I-} mkdir(fexpand(s)); {$I+} + if (ioresult<>0) then begin + writeln; + star('Error creating directory "'+fexpand(s)+'"'^G^G); + make_path:=FALSE; + end; +end; + +procedure make_paths; +var s:string; +begin + for i:=1 to 7 do begin + while copy(path[i],length(path[i]),1)='\' do + path[i]:=copy(path[i],1,length(path[i])-1); + case i of 1:s:='GFILES'; 2:s:='MSGS'; 3:s:='MENUS'; 4:s:='TFILES'; + 5:s:='AFILES'; 6:s:='TRAP'; 7:s:='TEMP'; end; + star(s+' path ("'+fexpand(path[i])+'")'); + if (not make_path(path[i])) then halt(1); + path[i]:=path[i]+'\'; + end; + star('Creating EMAIL and GENERAL message paths'); + if (not make_path(path[2]+'EMAIL\')) then halt(1); + if (not make_path(path[2]+'GENERAL\')) then halt(1); + star('Creating SYSOP and MISC file paths'); + if (not make_path('DLS\')) then halt(1); + if (not make_path('DLS\SYSOP')) then halt(1); + if (not make_path('DLS\MISC')) then halt(1); + star('Creating TEMP 1, 2, and 3 file paths'); + if (not make_path(path[7]+'1\')) then halt(1); + if (not make_path(path[7]+'2\')) then halt(1); + if (not make_path(path[7]+'3\')) then halt(1); +end; + +procedure make_status_dat; +begin + with systat do begin + bbsname:='Telegard BBS'; + bbsphone:='000-000-0000'; + sysopfirst:='System'; + sysoplast:='Operator'; + boardpw:=''; + sysoppw:='SYSOP'; + bbspw:='MATRIX'; + closedsystem:=FALSE; + matrix:=FALSE; + alias:=TRUE; + clearmsg:=TRUE; + fone:=TRUE; + multitask:=FALSE; + bwindow:=TRUE; + lock300:=FALSE; + wantquote:=TRUE; {* /// *} + mcimsg:=TRUE; {* /// *} + special:=TRUE; + localsec:=FALSE; + localscreensec:=FALSE; + autominlogon:=TRUE; + bullinlogon:=TRUE; + lcallinlogon:=TRUE; + autochatopen:=TRUE; + yourinfoinlogon:=TRUE; + globaltrap:=FALSE; + snowchecking:=FALSE; + forcevoting:=FALSE; + offhooklocallogon:=TRUE; + + with hmsg do begin ltr:='A'; number:=-32766; ext:=1; end; + {* A-32767.1 is the "Greetings from Telegard" message *} + tfiledate:='04/21/89'; + lastdate:='04/21/89'; + users:=1; + callernum:=0; + activetoday:=0; + callstoday:=0; + msgposttoday:=0; + emailtoday:=0; + fbacktoday:=0; + uptoday:=0; + newuk:=0; + newusertoday:=0; + dntoday:=0; + newdk:=0; + gfilepath:=path[1]; + pmsgpath:=path[2]+'EMAIL\'; + menupath:=path[3]; + tfilepath:=path[4]; + afilepath:=path[5]; + trappath:=path[6]; + temppath:=path[7]; + lowtime:=0; hitime:=0; + dllowtime:=0; dlhitime:=0; + b300lowtime:=0; b300hitime:=0; + b300dllowtime:=0; b300dlhitime:=0; + app:=1; + guestuser:=-1; + timeoutbell:=2; + timeout:=5; + sysopcolor:=4; usercolor:=3; + bsdelay:=20; + tosysopdir:=0; + comport:=1; + maxbaud:=1200; + init:='ATH0Q0V0E0M0X1S0=0S2=1S10=40&C1'; + hangup:='ATH'; + offhook:='ATH1'; + answer:='ATA'; + for i:=1 to 2 do + for j:=0 to 4 do begin + case i of + 1:case j of 0:k:=1; 1:k:=5; 2:k:=10; 3:k:=0; 4:k:=13; end; + 2:case j of 0:k:=0; 1:k:=15; 2:k:=16; 3:k:=0; 4:k:=17; end; + end; + resultcode[i][j]:=k; + end; + nocarrier:=3; + nodialtone:=6; + busy:=7; + nocallinittime:=30; + tries:=4; + newsl:=20; newdsl:=20; + newar:=[]; + newac:=[rpostan,rvoting]; + newfp:=0; + autosl:=50; autodsl:=50; + autoar:=[]; + autoac:=[]; + ansiq:='Display ANSI logon? '; + engage:='@M^3The SysOp brings you into chat!'; + endchat:='^3The SysOp returns you to the BBS....@M'; + sysopin:='^3The SysOp is probably around!'; + sysopout:='^3The SysOp is NOT here, or doesn''t want to chat'; + note[1]:='Enter your Telegard NAME or USER NUMBER'; + note[2]:='* NEW USERS, enter "NEW" *'; + lprompt:='Logon : '; + wait:='^3{-^9Please Wait^3-}'; + pause:='(* pause *)'; + msg1:='Enter message now. You have ^3@X^1 lines maximum.'; + msg2:='Enter ^3/S^1 to save. ^3/?^1 for a list of commands.'; + new1:='^7[^5@Y ^7- ^5@W msgs^7] ^4NewScan began.@M'; + new2:='^7[^5@Y ^7- ^5@W msgs^7] ^4NewScan complete.@M'; + read:='^3[^1@Y^3]@M^5[@U] ^4Read (1-@W,,T,Q,P,A,R,B,W,D) : '; + auto1:='^5AutoMessage by: '; + autom:='-'; + echoc:='X'; + + uldlratio:=TRUE; + fileptratio:=FALSE; + fileptcomp:=3; + fileptcompbasesize:=10; + + for i:=0 to 255 do begin + case i of 0..9:k:=1; 10..19:k:=10; 20..29:k:=20; 30..39:k:=40; + 40..49:k:=50; 50..59:k:=80; 60..69:k:=90; 70..79:k:=100; + 80..89:k:=110; 90..99:k:=120; 100..199:k:=130; + 200..239:k:=150; 240..249:k:=200; 250:k:=250; + 251..255:k:=6000; end; timeallow[i]:=k; + case i of 200..255:k:=20; 100..199:k:=15; 50..99:k:=10; + 30..49:k:=5; 20..29:k:=3; else k:=1; end; callallow[i]:=k; + case i of 60..255:k:=5; 20..59:k:=3; else k:=2; end; dlratio[i]:=k; + case i of 60..255:k:=10; 20..59:k:=5; else k:=2; end; dlkratio[i]:=k; + postratio[i]:=100; + end; + + normpubpost:=11; anonpubpost:=100; anonpubread:=100; + normprivpost:=11; anonprivpost:=100; anonprivread:=100; + maxpubpost:=20; maxprivpost:=20; + maxfback:=5; maxchat:=3; + maxwaiting:=15; csmaxwaiting:=50; + maxlines:=120; csmaxlines:=160; + + sop:=255; csop:=250; + msop:=199; fsop:=230; + spw:=250; seepw:=255; + nodlratio:=255; nopostratio:=200; + nofilepts:=255; seeunval:=50; + dlunval:=230; ulrefund:=100; + + eventwarningtime:=60; + filearccomment[1]:=bbsname+' '+bbsphone; + filearccomment[2]:=''; filearccomment[3]:=''; + + for i:=1 to 5 do + with filearcinfo[i] do + case i of + 1:begin + active:=TRUE; + ext:='ZIP'; + listline:='/1'; + arcline:='PKZIP -aeb4 @F @I'; + unarcline:='PKUNZIP @F @I'; + testline:='PKUNZIP -t @F'; + cmtline:='PKZIP -z @F'; + succlevel:=0; + end; + 2:begin + active:=FALSE; + ext:='ARC'; + listline:='/2'; + arcline:='PKPAK a @F @I'; + unarcline:='PKUNPAK @F @I'; + testline:='PKUNPAK -t @F'; + cmtline:='PKPAK x @F'; + succlevel:=0; + end; + 3:begin + active:=FALSE; + ext:='PAK'; + listline:='/2'; + arcline:='PAK a @F @I'; + unarcline:='PAK e @F @I'; + testline:=''; + cmtline:=''; + succlevel:=-1; + end; + 4:begin + active:=FALSE; + ext:='LZH'; + listline:='/4'; + arcline:='LHARC a @F @I'; + unarcline:='LHARC e @F @I'; + testline:=''; + cmtline:=''; + succlevel:=0; + end; + 5:begin + active:=FALSE; + ext:='ZOO'; + listline:='/3'; + arcline:='ZOO aP: @F @I'; + unarcline:='ZOO x @F @I'; + testline:='ZOO xNd @F'; + cmtline:='ZOO cA @F'; + succlevel:=0; + end; + end; + filearcinfo[6].ext:=''; + + minspaceforpost:=10; + minspaceforupload:=100; +postcredits:=0; {* not implemented *} +ulvalreq:=0; {* not implemented *} + moveline:=''; + backsysoplogs:=7; + compressbases:=FALSE; + + for i:=1 to 165 do res[i]:=0; + end; + assign(systatf,'status.dat'); + rewrite(systatf); write(systatf,systat); close(systatf); +end; + +procedure make_user_lst; +const dcols:clrs=((15,7,7,15,15,15,112,7,143,7),(15,3,1,11,9,14,31,4,140,10)); +begin + with u do begin + name:='SYSOP'; + realname:='System Operator'; + pw:='SYSOP'; + ph:='000-000-0000'; + bday:='00/00/00'; + firston:='04/21/89'; + laston:='04/21/89'; + street:=''; + citystate:=''; + zipcode:=''; + computer:='IBM Compatible'; + occupation:=''; + wherebbs:=''; + note:='Change these stats to yours.'; + lockedout:=FALSE; + deleted:=FALSE; + lockedfile:=''; + ac:=[onekey,wordwrap,pause,novice,ansi,color, + smw, {* short message waiting, in SHORTMSG.DAT *} + fnodlratio,fnopostratio,fnofilepts,fnodeletion]; + ar:=[]; for c:='A' to 'Z' do ar:=ar+[c]; + with qscan[1] do begin ltr:='A'; number:=-32767; ext:=1; end; + for i:=2 to maxboards do qscan[i]:=qscan[1]; + for i:=1 to maxboards do qscn[i]:=TRUE; + dlnscn:=[]; + for i:=0 to maxuboards do dlnscn:=dlnscn+[i]; + for i:=1 to 20 do vote[i]:=0; + sex:='M'; + ttimeon:=0.0; + uk:=0.0; + dk:=0.0; + uploads:=0; + downloads:=0; + loggedon:=0; + tltoday:=600; + msgpost:=0; + emailsent:=0; + feedback:=0; + forusr:=0; + filepoints:=0; + waiting:=1; {* A-32767.1 -- "Greetings from Telegard" message *} + linelen:=80; + pagelen:=23; {* to make room for SysOp window when on.. *} + ontoday:=0; + illegal:=0; + sl:=255; + dsl:=255; + cols:=dcols; + lastmsg:=1; + lastfil:=0; + credit:=0.0; + timebank:=0; + for i:=1 to 5 do boardsysop[i]:=255; + + trapactivity:=FALSE; + trapseperate:=FALSE; + +{* NEW STUFF *} + + timebankadd:=0; + mpointer:=-1; + +{* NEW STUFF *ENDS* *} + + for i:=1 to 70 do res[i]:=0; + end; + assign(uf,'user.lst'); + rewrite(uf); + seek(uf,0); write(uf,u); + seek(uf,1); write(uf,u); + close(uf); +end; + +procedure make_names_lst; +begin + with sr do begin + name:='SYSOP'; + number:=1; + end; + assign(sf,'names.lst'); + rewrite(sf); + seek(sf,0); write(sf,sr); + seek(sf,1); write(sf,sr); + close(sf); +end; + +procedure make_macro_lst; +var i:integer; +begin + with macr do + for i:=1 to 4 do macro[i]:=''; + assign(macrf,'macro.lst'); + rewrite(macrf); + seek(macrf,0); write(macrf,macr); + close(macrf); +end; + +procedure make_boards_dat; +begin + with br do begin + name:='General Messages'; + filename:='GENERAL'; + msgpath:=path[2]+'GENERAL\'; + sl:=30; + maxmsgs:=50; + password:=''; + anonymous:=no; + ar:='@'; + postsl:=30; + end; + assign(bf,'boards.dat'); + rewrite(bf); + seek(bf,0); write(bf,br); + close(bf); +end; + +procedure make_uploads_dat; +begin + assign(uff,'uploads.dat'); + rewrite(uff); + with ufr do begin + name:='SysOp directory'; + filename:='SYSOP'; + dlpath:=curdir+'\DLS\SYSOP\'; + noratio:=FALSE; + sl:=255; + dsl:=255; + namesl:=255; + ar:='@'; + maxfiles:=999; + agereq:=1; + password:=''; + arctype:=1; + cmttype:=1; + unhidden:=FALSE; + end; + write(uff,ufr); + with ufr do begin + name:='Miscellaneous'; + filename:='MISC'; + dlpath:=curdir+'\DLS\MISC\'; + noratio:=FALSE; + sl:=30; + dsl:=30; + namesl:=10; + ar:='@'; + maxfiles:=999; + agereq:=1; + password:=''; + arctype:=1; + cmttype:=1; + unhidden:=TRUE; + end; + write(uff,ufr); close(uff); +end; + +procedure make_protocol_dat; +begin + assign(xp,'protocol.dat'); + rewrite(xp); + for i:=1 to 11 do + with xpr do begin + rcmd:=''; scmd:=''; + rul:=FALSE; rdl:=FALSE; + sl:=0; dsl:=0; ar:='@'; + xferok:=-1; + if (i in [1..5]) then active:=TRUE else active:=FALSE; + case i of + 1:begin descr:='Ascii'; key:='A'; ptype:=1; rul:=TRUE; end; + 2:begin descr:='Xmodem'; key:='X'; ptype:=2; end; + 3:begin descr:='Xmodem CRC'; key:='C'; ptype:=3; end; + 4:begin descr:='Ymodem'; key:='Y'; ptype:=4; end; + 5:begin descr:='Ymodem'; key:='Y'; ptype:=5; rul:=TRUE; end; + 6:begin + descr:='Zmodem'; + key:='Z'; + ptype:=6; + rcmd:='dsz port @2 speed @1 rz @3'; + scmd:='dsz port @2 speed @1 sz @3'; + xferok:=0; + end; + 7:begin + descr:='Zmodem'; + key:='Z'; + ptype:=7; + rcmd:='dsz port @2 speed @1 rz'; + scmd:='dsz port @2 speed @1 @@4'; + xferok:=0; + end; + 8:begin + descr:='Zmodem '+#3#5+'Recovery'; + key:='Z'; + ptype:=8; + rcmd:='dsz port @2 speed @1 -r rz @3'; + scmd:='---'; + xferok:=0; + rdl:=TRUE; + end; + 9:begin + descr:='Lynx'; + key:='L'; + ptype:=6; + rcmd:='lynx R /@1 /@2 @3'; + scmd:='lynx S /@1 /@2 @3'; + xferok:=0; + end; + 10:begin + descr:='Lynx'; + key:='L'; + ptype:=7; + rcmd:='lynx R /@1 /@2'; + scmd:='lynx S /@1 /@2 @3'; + xferok:=0; + end; + 11:begin + descr:='Lynx '+#3#5+'Recovery'; + key:='L'; + ptype:=8; + rcmd:='lynx R /@1 /@2'; + scmd:='---'; + xferok:=0; + rdl:=TRUE; + end; + 12:begin + descr:='Jmodem'; + key:='J'; + ptype:=6; + rcmd:='jmodem R@2 @3'; + scmd:='jmodem S@2 @3'; + xferok:=-1; + end; + 13:begin + descr:='Megalink'; + key:='M'; + ptype:=6; + rcmd:='mlink PORT @2 SPEED @1 RM @3'; + scmd:='mlink PORT @2 SPEED @1 SM @3'; + xferok:=0; + end; + end; + write(xp,xpr); + end; + close(xp); +end; + +procedure make_zlog_dat; +begin + with zfr do begin + date:='04/21/89'; + active:=0; + calls:=0; + post:=0; + email:=0; + fback:=0; + up:=0; + end; + assign(zf,'zlog.dat'); + rewrite(zf); write(zf,zfr); + zfr.date:=''; + for i:=1 to 96 do write(zf,zfr); + close(zf); +end; + +procedure make_email_dat; +begin + with mr do begin + title:='Greetings from Telegard'; + from:=1; destin:=1; + with msg do begin ltr:='A'; number:=-32767; ext:=1; end; + mage:=255; + end; + mr.date:=daynum(date); + assign(mailfile,'email.dat'); + rewrite(mailfile); write(mailfile,mr); close(mailfile); +end; + +procedure make_events_dat; +begin + with evr do begin + active:=FALSE; + description:='A NEW Telegard Event'; + etype:='D'; + execdata:='event.bat'; + busytime:=5; + exectime:=0; + busyduring:=TRUE; + duration:=1; + execdays:=0; + monthly:=FALSE; + end; + assign(evf,'events.dat'); + rewrite(evf); write(evf,evr); close(evf); +end; + +procedure make_laston_dat; +begin + with lcall do begin + callernum:=0; + name:='Eric Oman'; + number:=1; + citystate:='Grosse Pointe Woods, Michigan'; + end; + assign(lcallf,'laston.dat'); + rewrite(lcallf); write(lcallf,lcall); + lcall.callernum:=-1; + for i:=1 to 9 do write(lcallf,lcall); + close(lcallf); +end; + +procedure make_gfiles_dat; +begin + assign(tfilf,'gfiles.dat'); + rewrite(tfilf); + for i:=0 to 1 do begin + with tfil do + case i of + 0:begin + num:=1; {* 1 entry total *} + title:=''; + filen:=''; + ar:='@'; + gdate:='04/21/89'; + gdaten:=daynum(gdate); + end; + 1:begin + num:=0; {* SL level *} + title:='Miscellaneous'; + filen:=#1#0#0#0#0#0; + ar:='@'; + gdate:='04/21/89'; + gdaten:=daynum(gdate); + end; + end; + write(tfilf,tfil); + end; + close(tfilf); +end; + +procedure make_verbose_dat; +begin + with vr do + for i:=1 to 4 do descr[i]:=''; + assign(verbf,'verbose.dat'); + rewrite(verbf); write(verbf,vr); close(verbf); +end; + +procedure make_voting_dat; +begin + with vd do begin + question:='<< No Question >>'; + numa:=0; + for i:=0 to 9 do + with answ[i] do begin + if (i<>0) then ans:='Selection '+chr(i+48) else ans:='No Comment'; + numres:=0; + end; + end; + assign(vdata,'voting.dat'); + rewrite(vdata); + for i:=0 to 19 do write(vdata,vd); + close(vdata); +end; + +procedure make_shortmsg_dat; +begin + with sm do begin + msg:='Telegard files initialized on '+date+' '+time+'.'; + destin:=1; + end; + assign(smf,'shortmsg.dat'); + rewrite(smf); write(smf,sm); close(smf); +end; + +procedure make_mboard(s:string); +var f:file; +begin + msr.message.number:=0; + assign(f,s+'.BRD'); + rewrite(f,sizeof(messagerec)); blockwrite(f,msr,1); close(f); +end; + +procedure make_fboard(s:string); +begin + ulffr.blocks:=0; + assign(ulff,s+'.DIR'); + rewrite(ulff); write(ulff,ulffr); close(ulff); +end; + +procedure dostuff; +begin + ttl('Creating Telegard directory paths'); + make_paths; + ttl('Creating Telegard data files'); + make_status_dat; + make_user_lst; + make_names_lst; + make_macro_lst; + make_boards_dat; + make_uploads_dat; + make_protocol_dat; + make_zlog_dat; + make_email_dat; + make_events_dat; + make_laston_dat; + make_gfiles_dat; + make_verbose_dat; + make_voting_dat; + make_shortmsg_dat; + make_mboard('general'); + make_fboard('sysop'); + make_fboard('misc'); + ttl('Moving data files into GFILES directory'); + movefile('user.lst',path[1]); + movefile('names.lst',path[1]); + movefile('macro.lst',path[1]); + movefile('boards.dat',path[1]); + movefile('email.dat',path[1]); + movefile('events.dat',path[1]); + movefile('gfiles.dat',path[1]); + movefile('laston.dat',path[1]); + movefile('protocol.dat',path[1]); + movefile('shortmsg.dat',path[1]); + movefile('uploads.dat',path[1]); + movefile('verbose.dat',path[1]); + movefile('voting.dat',path[1]); + movefile('zlog.dat',path[1]); + movefiles('*.BRD',path[1]); + movefiles('*.DIR',path[1]); + ttl('Moving miscellaneous text files into AFILES directory'); + movefiles('*.ANS',path[5]); + movefiles('*.MSG',path[5]); + movefiles('*.TUT',path[5]); + movefile('computer.txt',path[5]); + ttl('Moving message file into MSGS\EMAIL directory'); + movefile('a-32767.1',path[2]+'EMAIL\'); + ttl('Moving menu files into MENUS directory'); + movefiles('*.MNU',path[3]); +end; + +begin + infield_out_fgrd:=11; + infield_out_bkgd:=0; + infield_inp_fgrd:=15; + infield_inp_bkgd:=1; + + clrscr; + gotoxy(1,1); textbackground(1); textcolor(15); + clreol; write(' Initialization Utility for Telegard version '+ver); + textbackground(0); textcolor(7); + window(1,2,80,25); + writeln; + assign(systatf,'status.dat'); + {$I-} reset(systatf); {$I+} + if ioresult=0 then begin + textcolor(28); write('WARNING!!'); + textcolor(14); writeln(' "STATUS.DAT" file already exists..'); + writeln('Telegard has already been initialized!'); + writeln('If you proceed, ALL DATA FILES WILL BE ERASED AND INITIALIZED!!!'); + writeln; + if not pynq('Proceed? ') then halt(1); + writeln; + end; + + getdir(0,curdir); + path[1]:=curdir+'\GFILES\'; + path[2]:=curdir+'\MSGS\'; + path[3]:=curdir+'\MENUS\'; + path[4]:=curdir+'\TFILES\'; + path[5]:=curdir+'\AFILES\'; + path[6]:=curdir+'\TRAP\'; + path[7]:=curdir+'\TEMP\'; + + textcolor(14); + writeln; + writeln('You will now be prompted several times for names of directorys'); + writeln('that will be used by Telegard. Each directory will be created'); + writeln('and the appropriate files will be moved there-in.'); + writeln; + writeln('GFILES pathname. This is the directory where the Telegard data'); + writeln('files and miscellaneous Telegard text files will be located.'); + writeln; + prt('GFILES dirname: '); infielde(path[1],60); writeln; writeln; + + textcolor(14); + writeln('MSGS pathname. This directory should contain all the other message'); + writeln('directory paths used by Telegard, including private mail (EMAIL).'); + writeln('Located in these paths are the text of the Telegard messages.'); + writeln; + prt('MSGS dirname: '); infielde(path[2],60); writeln; writeln; + + textcolor(14); + writeln('MENUS pathname. This is the directory where the Telegard menu'); + writeln('files will be located.'); + writeln; + prt('MENUS dirname: '); infielde(path[3],60); writeln; writeln; + + textcolor(14); + writeln('TFILES pathname. This is the directory where the Telegard'); + writeln('"text file section" text files will be located in.'); + writeln; + prt('TFILES dirname: '); infielde(path[4],60); writeln; writeln; + + textcolor(14); + writeln('AFILES pathname. This is the directory where the Telegard'); + writeln('menu help files, ANSI displays, etc. will be located.'); + writeln; + prt('AFILES dirname: '); infielde(path[5],60); writeln; writeln; + + textcolor(14); + writeln('TRAP pathname. This is the directory where Telegard will'); + writeln('output all User Audit traps to. In the future, CHAT.MSG,'); + writeln('SYSOP*.LOG, FILE*.LOG, etc. will be stored here as well.'); + writeln; + prt('TRAP dirname: '); infielde(path[6],60); writeln; writeln; + + textcolor(14); + writeln('TEMP pathname. Telegard uses this directory to convert between'); + writeln('archive formats, receive batch uploads, and allow users to'); + writeln('decompress archives to download single files, etc.'); + writeln; + prt('TEMP dirname: '); infielde(path[7],60); writeln; writeln; + + clrscr; + + dostuff; + + writeln; + star('Telegard BBS installed and initialized successfully!'); + star('This program, "INIT.EXE", can now be deleted.'); + star('Thanks for trying Telegard!'); +end. diff --git a/initp.pas b/initp.pas new file mode 100644 index 0000000..b503f15 --- /dev/null +++ b/initp.pas @@ -0,0 +1,568 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit initp; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + myio, + common; + +procedure readp; +procedure initp1; +procedure init; + +implementation + +const + openedyet:boolean=FALSE; + +procedure scroll_clear(t:integer); +var i,j,k:integer; +begin + case t of + 1:for i:=0 to 1 do + for j:=1 to 5 do + for k:=1 to 5 do + begin + window(1,(k-1)*5+1,80,k*5); + textcolor(7); + textbackground(i); + gotoxy(1,5); + writeln; + end; + 2:for i:=1 downto 0 do + for j:=1 to 5 do + for k:=1 to 5 do + begin + window(1,(k-1)*5+1,80,k*5); + textcolor(7); + textbackground(i); + gotoxy(1,j); + clreol; + end; + end; + window(1,1,80,25); +end; + +procedure tanim; +var s:array[1..5] of string; + i,j:integer; +begin + s[1]:=' °±²²²²²²²² °±²²²²²² °±²² °±²²²²²² °±²²²²²² °±²²²²² °±²²²²²² °±²²²²²² '; + s[2]:=' °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²²'; + s[3]:=' °±²² °±²²²²² °±²² °±²²²²² °±²² °±²² °±²²²²²²² °±²²²²²² °±²² °±²²'; + s[4]:=' °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²² °±²²'; + s[5]:=' °±²² °±²²²²²² °±²²²²²²² °±²²²²²² °±²²²²²² °±²² °±²² °±²² °±²² °±²²²²²² '; + textbackground(1); textcolor(15); clrscr; +(* + for i:=30 downto 0 do begin + gotoxy(1,20); + for j:=1 to 5 do writeln(copy(s[j],(i)*(j-1),length(s[j]))); + end; + for i:=18 downto 2 do begin + gotoxy(1,i); + for j:=1 to 5 do writeln(s[j]); + writeln(s[5]); + end; + for i:=24 downto 7 do begin + gotoxy(1,i); + clreol; + end; +*) + gotoxy(1,2); + for j:=1 to 5 do writeln(s[j]); +end; + +procedure readp; +var filv:text; + d:astr; + a,count:integer; + + function sc(s:astr; i:integer):char; + begin + s:=allcaps(s); sc:=s[i]; + end; + + procedure wpar(s:astr); + begin + writeln(' '+s); + end; + + function atoi(s:astr):word; + var i,code:integer; + begin + val(s,i,code); + if code<>0 then i:=0; + atoi:=i; + end; + +begin + cursoron(FALSE); exteventtime:=0; + answerbaud:=0; quitafterdone:=FALSE; returna:=FALSE; nightly:=FALSE; + {minitermonly:=FALSE;} localioonly:=FALSE; + a:=0; + while (a=4) then begin + d:=allcaps(paramstr(a)); + case d[3] of + 'E':exiterrors:=value(copy(d,4,length(d)-3)); + 'N':exitnormal:=value(copy(d,4,length(d)-3)); + end; + end; + 'K':localioonly:=TRUE; + {'M':minitermonly:=TRUE;} + 'N':nightly:=TRUE; + 'P':packbasesonly:=TRUE; + 'Q':quitafterdone:=TRUE; + 'X':exteventtime:=atoi(copy(paramstr(a),3,length(paramstr(a))-2)); + end; + end; + + textcolor(15); textbackground(1); gotoxy(1,2); + tanim; + gotoxy(6,10); writeln('Initializing file'); + textbackground(7); textcolor(0); + gotoxy(6,11); repeat write(' ') until wherex>=76; + textbackground(1); + + gotoxy(6,15); textcolor(14); write('Command parameters specified:'); + writeln; + textcolor(15); + if (paramcount=0) then wpar('None'); + if (exitnormal<>255) then wpar('Normal exit Errorlevel = '+cstr(exitnormal)); + if (exiterrors<>254) then wpar('Critical Error exit Errorlevel = '+cstr(exiterrors)); + if (nightly) then wpar('Execute Nightly Event'); + if (localioonly) then wpar('Local I/O ONLY'); + if (answerbaud>0) then wpar('Answer at '+cstr(answerbaud)+' baud'); + if (exteventtime>0) then wpar('External event in '+cstr(exteventtime)+' minute(s)'); + if (quitafterdone) then wpar('Quit after user logoff'); + {if (minitermonly) then wpar('MiniTerm only');} + if (packbasesonly) then wpar('Pack message bases only'); + allowabort:=TRUE; +end; + +procedure initp1; +var filv:text; + {systatf:file of systatrec;} + evf:file of eventrec; + fstringf:file of fstringrec; + modemrf:file of modemrec; + fidorf:file of fidorec; + fp:file; + wind:windowrec; + v:verbrec; + sx,sy,numread,i:integer; + errs,npatch:boolean; + s:astr; + + procedure showmem; + var i,p:longint; + begin + textbackground(1); textcolor(15); gotoxy(20,13); + p:=40-(((40*memavail) div MaxHeapSpace)+1); + for i:=1 to 40 do + if (p>i+1) then begin + inc(i); write('Û'); + end else + if (p>i) then write('Ý'); + gotoxy(49,13); write(memavail,' bytes left'); + end; + + procedure show_initfile(s:astr); + + function nocaps(s:astr):astr; + var i:integer; + begin + for i:=1 to length(s) do + if (s[i] in ['A'..'Z']) then s[i]:=chr(ord(s[i])+32); + nocaps:=s; + end; + + begin + textbackground(7); textcolor(0); + gotoxy(6,11); repeat write(' ') until wherex>=76; + gotoxy(6,11); + if (copy(s,length(s),1)<>'!') then s:=systat.gfilepath+s + else s:=copy(s,1,length(s)-1); + write(caps(s)); + textbackground(1); + showmem; + errs:=FALSE; npatch:=FALSE; + end; + + procedure openwmsgs; + begin + openedyet:=TRUE; + setwindow(wind,6,15,75,23,15,1,7); clrscr; + sx:=1; sy:=1; + end; + + procedure wmsgs(s:astr); + var x,y:integer; + begin + x:=wherex; y:=wherey; + if (not openedyet) then openwmsgs; + textbackground(1); textcolor(15); + window(8,16,73,22); + gotoxy(sx,sy); writeln(s); sx:=wherex; sy:=wherey; + window(1,1,80,25); gotoxy(x,y); + end; + + procedure inmsgs(sh:astr; var s:astr; len:integer); + var x,y:integer; + begin + x:=wherex; y:=wherey; + wmsgs(sh); + textbackground(1); textcolor(15); + window(8,16,73,22); + gotoxy(sx,sy); + infielde(s,len); + window(1,1,80,25); gotoxy(x,y); + end; + + function existdir(fn:astr):boolean; + var srec:searchrec; + begin + while (fn[length(fn)]='\') do fn:=copy(fn,1,length(fn)-1); + findfirst(fexpand(sqoutsp(fn)),anyfile,srec); + existdir:=(doserror=0) and (srec.attr and directory=directory); + end; + + procedure abend(s:astr); + begin + wmsgs('*'+s+'* -- Aborting'); + window(1,1,80,25); gotoxy(1,24); delay(3000); + halt(exiterrors); + end; + + procedure findbadpaths; + var s,s1,s2:astr; + i:integer; + begin + infield_out_fgrd:=15; + infield_out_bkgd:=1; + infield_inp_fgrd:=0; + infield_inp_bkgd:=7; + + with systat do + for i:=1 to 8 do begin + case i of 1:s1:='GFILES'; 2:s1:='MSGS'; 3:s1:='MENUS'; 4:s1:='TFILES'; + 5:s1:='AFILES'; 6:s1:='LOG'; 7:s1:='TEMP'; 8:s1:='SWAP'; + end; + case i of + 1:s:=gfilepath; 2:s:=msgpath; + 3:s:=menupath; 4:s:=tfilepath; + 5:s:=afilepath; 6:s:=trappath; + 7:s:=temppath; 8:s:=swappath; + end; + if (not existdir(s)) then begin + cursoron(TRUE); + wmsgs(''); + wmsgs(''); + wmsgs(s1+' path is currently "'+s+'"'); + wmsgs('This path is bad or missing.'); + repeat + wmsgs(''); + s2:=s; inmsgs('New '+s1+' path: ',s2,60); s2:=allcaps(sqoutsp(s2)); + if (s=s2) or (s2='') then abend('Illegal pathname error') + else begin + if (s2<>'') then + if (copy(s2,length(s2),1)<>'\') then s2:=s2+'\'; + if (existdir(s2)) then + case i of + 1:gfilepath:=s2; 2:msgpath:=s2; + 3:menupath:=s2; 4:tfilepath:=s2; + 5:afilepath:=s2; 6:trappath:=s2; + 7:temppath:=s2; 8:swappath:=s2; + end + else begin + wmsgs(''); + wmsgs('That path does not exist!'); + end; + end; + until (existdir(s2)); + cursoron(FALSE); + end; + end; + end; + +begin + gotoxy(6,10); writeln('Initializing file'); + textbackground(7); textcolor(0); + gotoxy(6,11); repeat write(' ') until wherex>=76; + + textbackground(1); textcolor(15); + gotoxy(6,13); writeln('Record space ÞúúúúúúúúúúúúúúúúúúúúÝ'); + + wantout:=TRUE; + ldate:=daynum(date); + ch:=FALSE; lil:=0; thisuser.pagelen:=20; buf:=''; chatcall:=FALSE; + spd:=''; lastname:=''; ll:=''; chatr:=''; textcolor(0); + cursoron(FALSE); textcolor(0); + +(* + show_initfile(start_dir+'\status.dat!'); + assign(systatf,'status.dat'); + {$I-} reset(systatf); {$I+} + errs:=(ioresult<>0); + if (errs) then begin + wmsgs('Unable to find STATUS.DAT data file. This file is absolutely'); + wmsgs('*REQUIRED* to even load the BBS. If you cannot find your'); + wmsgs('STATUS.DAT data file, re-create one using the INIT package.'); + wmsgs(''); + delay(1000); abend('Cannot find STATUS.DAT'); + end else begin + {$I-} read(systatf,systat); {$I+} + errs:=(ioresult<>0); + close(systatf); + end; +*) + + if (exist(start_dir+'\critical.err')) then begin + assign(filv,start_dir+'\critical.err'); erase(filv); + wmsgs('*** Critical error during last BBS execution! ***'); + wmsgs('[>>> Updating STATUS.DAT <<<]'); + inc(systat.todayzlog.criterr); + savesystat; + wascriterr:=TRUE; + end; + + findbadpaths; + + assign(fp,'msgtmp'); + {$I-} reset(fp); {$I+} + if (ioresult=0) then begin close(fp); erase(fp); end; + + show_initfile(systat.trappath+'sysop.log!'); + assign(sysopf,systat.trappath+'sysop.log'); + {$I-} append(sysopf); {$I+} + if (ioresult<>0) then begin + wmsgs('Bad or missing SYSOP.LOG - creating...'); + rewrite(sysopf); + writeln(sysopf); + end; + + assign(sysopf1,systat.trappath+'slogxxxx.log'); + + showmem; + + first_time:=TRUE; + sl1(#3#7+'---------------> '+#3#5+'System booted on '+dat+#3#7+' <---------------'); + + + show_initfile('modem.dat'); + assign(modemrf,systat.gfilepath+'modem.dat'); + reset(modemrf); read(modemrf,modemr); close(modemrf); + + show_initfile('string.dat'); + assign(fstringf,systat.gfilepath+'string.dat'); + reset(fstringf); read(fstringf,fstring); close(fstringf); + + show_initfile('fidonet.dat'); + assign(fidorf,systat.gfilepath+'fidonet.dat'); + {$I-} reset(fidorf); {$I+} + if (ioresult<>0) then begin + wmsgs('Bad or missing FIDONET.DAT - creating...'); + rewrite(fidorf); + with fidor do begin + zone:=0; net:=0; node:=0; point:=0; + for i:=1 to 50 do origin[i]:=chr(0); + origin:=copy(stripcolor(systat.bbsname),1,50); + text_color:=1; quote_color:=3; tear_color:=9; origin_color:=5; + skludge:=TRUE; sseenby:=TRUE; sorigin:=FALSE; + scenter:=TRUE; sbox:=TRUE; mcenter:=TRUE; + for i:=1 to sizeof(res) do res[i]:=0; + end; + write(fidorf,fidor); + end else read(fidorf,fidor); + close(fidorf); + + show_initfile('names.lst'); + assign(sf,systat.gfilepath+'names.lst'); + {$I-} reset(sf); {$I+} + if (ioresult<>0) then abend('Bad or missing NAMES.LST'); + close(sf); + showmem; + + show_initfile('user.lst'); + assign(uf,systat.gfilepath+'user.lst'); + reset(uf); + if (filesize(uf)>1) then begin + seek(uf,1); + read(uf,thisuser); + end else + thisuser.slogseperate:=FALSE; + reset(sf); + if (systat.numusers<>filesize(sf)) then begin + wmsgs('User count does not match with names list - fixing...'); + wmsgs('(NAMEFIX should be used, just to be safe)'); + systat.numusers:=filesize(sf); + savesystat; + end; +(* if (systat.numusers>filesize(uf)-1) then begin + wmsgs('NAMES.LST does not match up with USER.LST'); + wmsgs('NAMEFIX should be ran!'); + sysoplog(#3#7+'NAMES.LST does not match up with USER.LST'); + sysoplog(#3#8+'NAMEFIX should be ran!'); + end;*) + close(sf); + close(uf); + +(* show_initfile('macro.lst'); + assign(macrf,systat.gfilepath+'macro.lst'); + {$I-} reset(macrf); {$I+} + if (ioresult<>0) then begin + wmsgs('Missing MACRO.LST - creating...'); + rewrite(macrf); + end; + close(macrf);*) + + show_initfile('verbose.dat'); + assign(verbf,systat.gfilepath+'verbose.dat'); + {$I-} reset(verbf); {$I+} + if (ioresult<>0) then rewrite(verbf); + close(verbf); reset(verbf); + {$I-} seek(verbf,0); read(verbf,v); {$I+} + if (ioresult<>0) then begin + wmsgs('Bad or missing VERBOSE.DAT - creating...'); + rewrite(verbf); + v.descr[1]:=''; + write(verbf,v); + end; + close(verbf); + + show_initfile('protocol.dat'); + assign(xf,systat.gfilepath+'protocol.dat'); + reset(xf); close(xf); + + show_initfile('events.dat'); + new(events[0]); + with events[0]^ do begin + active:=nightly; + description:='Telegard Nightly Events'; + etype:='D'; + execdata:='night.bat'; + busytime:=15; + exectime:=240; {* 4:00am *} + busyduring:=TRUE; + duration:=1; + execdays:=127; {* SMTWTFS *} + monthly:=FALSE; + end; + assign(fp,systat.gfilepath+'events.dat'); + assign(evf,systat.gfilepath+'events.dat'); + {$I-} reset(fp,1); {$I+} + if (ioresult<>0) then begin + wmsgs('Bad or missing EVENTS.DAT - creating...'); + rewrite(evf); numevents:=1; new(events[1]); + with events[1]^ do begin + active:=FALSE; + description:='A NEW Telegard Event'; + etype:='D'; + execdata:='event.bat'; + busytime:=5; + exectime:=0; + busyduring:=TRUE; + duration:=1; + execdays:=0; + monthly:=FALSE; + end; + write(evf,events[1]^); + end else begin + numevents:=0; + repeat + inc(numevents); + new(events[numevents]); (* DEFINE DYNAMIC MEMORY! *) + blockread(fp,events[numevents]^,sizeof(eventrec),numread); + if ((numread<>sizeof(eventrec)) and (numread<>0)) then npatch:=TRUE; + showmem; + until (numread<>sizeof(eventrec)) or (eof(fp)); + end; + close(fp); + if (npatch) then begin + wmsgs('Errors in EVENTS.DAT - patching...'); + rewrite(evf); + for i:=1 to numevents do write(evf,events[i]^); + close(evf); + end; + + show_initfile('boards.dat'); + assign(fp,systat.gfilepath+'boards.dat'); + assign(bf,systat.gfilepath+'boards.dat'); + reset(fp,1); numboards:=0; + repeat + inc(numboards); + blockread(fp,memboard,sizeof(boardrec),numread); + if ((numread<>sizeof(boardrec)) and (numread<>0)) then npatch:=TRUE; + showmem; + until (numread<>sizeof(boardrec)) or (eof(fp)); + close(fp); + if (npatch) then + wmsgs(^G'Errors in BOARDS.DAT - run FIX for BOARDS.DAT...'^G); + + show_initfile('uploads.dat'); + assign(fp,systat.gfilepath+'uploads.dat'); + assign(ulf,systat.gfilepath+'uploads.dat'); + reset(fp,1); maxulb:=-1; + repeat + inc(maxulb); + blockread(fp,memuboard,sizeof(ulrec),numread); + if ((numread<>sizeof(ulrec)) and (numread<>0)) then npatch:=TRUE; + showmem; + until (numread<>sizeof(ulrec)) or (eof(fp)); + close(fp); + if (npatch) then + wmsgs(^G'Errors in UPLOADS.DAT - run FIX for UPLOADS.DAT...'^G); + +(* show_initfile('email.dat'); + assign(mailfile,systat.gfilepath+'email.dat');*) + + show_initfile('shortmsg.dat'); + assign(smf,systat.gfilepath+'shortmsg.dat'); + +{ show_initfile(systat.trappath+'chat.msg!'); + assign(cf,systat.trappath+'chat.msg');} + cfo:=FALSE; + + if (openedyet) then removewindow(wind); + textbackground(0); textcolor(7); clrscr; +end; + +procedure init; +var rcode:integer; +begin + if (daynum(date)=0) then begin + clrscr; + writeln('Please set the date & time, it is required for operation.'); + halt(exiterrors); + end; + + hangup:=FALSE; incom:=FALSE; outcom:=FALSE; + echo:=TRUE; doneday:=FALSE; + checkbreak:=FALSE; + slogging:=TRUE; trapping:=FALSE; + readingmail:=FALSE; sysopon:=FALSE; inmsgfileopen:=FALSE; + beepend:=FALSE; + wascriterr:=FALSE; + checksnow:=systat.cgasnow; + directvideo:=not systat.usebios; + + readp; initp1; + +(* setuprs232(modemr.comport,4,0,8,1); + installint(modemr.comport); {installint(2);}*) + iport; + + if (exist('bbsstart.bat')) then shelldos(FALSE,'bbsstart.bat',rcode); +end; + +end. diff --git a/ints.inc b/ints.inc new file mode 100644 index 0000000..dba6c5f --- /dev/null +++ b/ints.inc @@ -0,0 +1,15 @@ +{Include file INTS.INC. INLINE macros to disable and enable interrupts.} + +PROCEDURE disable_interrupts; +INLINE + ( + $FA {CLI} + ); + +PROCEDURE enable_interrupts; +INLINE + ( + $FB {STI} + ); + + diff --git a/lamer.pas b/lamer.pas new file mode 100644 index 0000000..1c8f7c4 --- /dev/null +++ b/lamer.pas @@ -0,0 +1,5 @@ +uses newcom; + +begin + tty(TRUE); +end. diff --git a/lcbbs.pas b/lcbbs.pas new file mode 100644 index 0000000..caf1a43 --- /dev/null +++ b/lcbbs.pas @@ -0,0 +1 @@ +lastcompiled='Last official compilation date: < 6:54 pm Thu May 03, 1990 >'; diff --git a/logon1.pas b/logon1.pas new file mode 100644 index 0000000..16d344a --- /dev/null +++ b/logon1.pas @@ -0,0 +1,582 @@ +(*****************************************************************************) +(*> <*) +(*> LOGON1 .PAS - Written by Eric Oman <*) +(*> <*) +(*> Logon functions -- Part 1. <*) +(*> <*) +(*****************************************************************************) +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit logon1; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + logon2, newusers, + mail0, mail1, mail2, mail3, mail4, + misc2, miscx, + cuser, + doors, + archive1, + menus, menus2, + common; + +function getuser:boolean; + +implementation + +const + ilogon=^G'FAILED LOGON ATEMP'^G; + +procedure getpws(var ok:boolean; var tries:integer); +var phone,pw,s:astr; +begin + ok:=TRUE; echo:=FALSE; + commandline('Password - "'+thisuser.pw+'"'); + sprompt(#3#0+'User password : '+#3#5); input(pw,20); + if (systat.phonepw) then + begin + commandline('Phone # - "'+thisuser.ph+'"'); + sprompt(#3#0+'Complete phone #: '+#3#5+'###-###-'); + input(phone,4); echo:=TRUE; + end else + phone:=(copy(thisuser.ph,9,4)); + echo:=TRUE; + if ((thisuser.pw<>pw) or (copy(thisuser.ph,9,4)<>phone)) then + begin + nl; print(ilogon); nl; + if (not hangup) and (usernum<>0) then begin + s:=#3#8+'>>'+#3#1+' Illegal logon attempt! Tried: '+ + caps(thisuser.name)+' #'+cstr(usernum); + if (usernum<>1) then + begin + s:=s+' PW="'+pw+'"'; + if (systat.phonepw) then s:=s+', PH#="'+phone+'"'; + end; + sl1(s); + end; + inc(thisuser.illegal); + seek(uf,usernum); write(uf,thisuser); + inc(tries); if (tries>=systat.maxlogontries) then hangup:=TRUE; + ok:=FALSE; + end; + if ((aacs(systat.spw)) and (ok) and (incom) and (not hangup)) then + begin + echo:=FALSE; + sprompt(#3#0+'System password: '+#3#5); + input(pw,20); + if (pw<>systat.sysoppw) then + begin + nl; print(ilogon); nl; + sl1(#3#8+'>>'+#3#1+' Illegal System password'); inc(tries); + if (tries>=systat.maxlogontries) then hangup:=TRUE; + ok:=FALSE; + end; + echo:=TRUE; + end; + if ((ok) and (systat.shuttlelog) and (thisuser.lockedout)) then + begin + printf(thisuser.lockedfile); + sysoplog(#3#7+'['+#3#8+'*'+#3#7+'] '+#3#3+thisuser.name+#3#7+' --> '+#3#5+ + 'Attempt to access system when locked out'+#3#7+' <--'); + hangup:=TRUE; + end; +end; + +procedure doshuttle; +var s,cmd,pw,newmenucmd:astr; + tries,i,nocsave:integer; + loggedon,gotname,noneedname,ok,cmdnothid,cmdexists:boolean; +begin + nl; + print('[> Project Coyote / Shuttle Logon @ '+dat+' ('+spd+' bps)'); + nl; + with thisuser do + begin + if pynq('Do you desire ANSI graphics? ') then ac:=ac+[ansi] else ac:=ac-[ansi]; + ac:=ac-[avatar]; + end; + nl; printf('preshutl'); last_menu:='shuttle.mnu'; + curmenu:=systat.menupath+last_menu; readin; + + loggedon:=FALSE; gotname:=FALSE; tries:=0; + + chelplevel:=2; + repeat + tshuttlelogon:=0; + mainmenuhandle(cmd); + if ((not gotname) and (cmd<>'')) then + begin + noneedname:=TRUE; i:=0; + repeat + fcmd(cmd,i,noc,cmdexists,cmdnothid); + if (i<>0) then + if (cmdr[i].cmdkeys<>'OP') and (cmdr[i].cmdkeys<>'O1') and + (cmdr[i].cmdkeys<>'O2') and (cmdr[i].cmdkeys[1]<>'H') then + noneedname:=FALSE; + until (i=0); + if (not noneedname) then + begin + nl; + sprompt(#3#0+'Enter your user name or number : '); + finduser(s,usernum); + if (usernum>=1) then begin + reset(uf); seek(uf,usernum); read(uf,thisuser); + getpws(ok,tries); + gotname:=ok; + nl; + if (gotname) then + begin + readinmacros; readinzscan; useron:=TRUE; + schangewindow(TRUE,systat.curwindow); commandline(''); + print('"'+thisuser.name+'" logged on.'); + sysoplog('Logged on to Shuttle Menu as '+caps(thisuser.name)+' #'+ + cstr(usernum)); + if (thisuser.waiting<>0) then + begin + nl; nl; + sprint(#3#5+'NOTE: '+#3#3+'You have '+ + #3#0+cstr(thisuser.waiting)+ + #3#3+' pieces of mail waiting.'); + nl; + if pynq('Read it now? ') then readmail; + nl; + end; + end; + end else + print('You are not a member of this BBS.'); + end; + end; + if ((gotname) or (noneedname)) then + begin + newmenucmd:=''; + repeat domenuexec(cmd,newmenucmd) until (newmenucmd=''); + case tshuttlelogon of + 1:if (systat.shuttlepw='') then loggedon:=TRUE + else begin + nl; + echo:=FALSE; + sprompt(#3#0+'Enter BBS Password: '); input(pw,20); nl; + echo:=TRUE; + if (pw=systat.shuttlepw) then loggedon:=TRUE + else begin + sl1(#3#8+'>>'+#3#1+' Illegal Shuttle Logon password: "'+pw+'"'); + print(ilogon); + inc(tries); + end; + end; + 2:if (gotname) then + begin + nl; + print('You already ARE a user!'); + print('Why do you want to log on as new again!?'); + print('Sheesshhhhh.....'); + delay(1500); + end else + begin + nl; + if pynq('Log on as a NEW USER? ') then + begin + newuserinit(''); + newuser; + if (usernum>0) and (not hangup) then + begin + gotname:=TRUE; useron:=TRUE; logon1st; + end; + end; + end; + 3:if ((thisuser.sl>systat.newsl) or + (thisuser.dsl>systat.newdsl)) then + begin + sysoplog('Found out the Shuttle password.'); nl; + print('You are a validated member of this BBS.'); + print('The BBS password is "'+systat.shuttlepw+'"'); + sprint('^3Write it down ^1for faster logons in the future!'); + nl; loggedon:=pynq('Log on now? '); + end else + begin + nl; print('Sorry, you have not been validated yet.'); + sysoplog('Tried to find out Shuttle password - was not validated.'); + end; + end; + end; + if (tries=systat.maxlogontries) then hangup:=TRUE; + until (loggedon) or (hangup); +end; + +procedure getacsuser(eventnum:integer; acsreq:astr); +var user:userrec; + sr:smalrec; + r:real; + s,pw:astr; + cp,un,i:integer; + c:char; + sfo:boolean; + + procedure dobackspace; + begin + dec(cp); + outkey(^H); outkey(' '); outkey(^H); + end; + +begin + printf('acsea'+cstr(eventnum)); + if (nofile) then begin + print('Restricted time zone.'); + print('Only certain users allowed online at this time.'); + end; + nl; + print('Current time: '+date+' '+time+'.'); + print('Enter your user name/number *now*.'); + print('If you do not enter within 20 seconds, you will be hung up.'); + prt(':'); + checkhangup; + if (hangup) then exit; + r:=timer; s:=''; cp:=1; echo:=TRUE; + repeat + checkhangup; + c:=inkey; + if (c<>#0) then + case c of + ^H:if (cp>1) then dobackspace; + ^X:while (cp<>1) do dobackspace; + #32..#255: + if (cp<=36) then begin + c:=upcase(c); + outkey(c); + s[cp]:=c; inc(cp); + end; + end; + if (timer-r>20.0) then hangup:=TRUE; + until ((c=^M) or (hangup)); + s[0]:=chr(cp-1); + if (not hangup) then begin + nl; nl; + un:=value(s); + if (un<>0) then begin + reset(uf); + if (un>filesize(uf)-1) then un:=0 + else begin + seek(uf,un); + read(uf,user); + end; + close(uf); + end else begin + sfo:=(filerec(sf).mode<>fmclosed); + if (not sfo) then reset(sf); + un:=0; i:=1; + while ((i<=filesize(sf)-1) and (un=0)) do begin + seek(sf,i); read(sf,sr); + if (s=sr.name) then un:=sr.number; + inc(i); + end; + if (un>filesize(sf)-1) then un:=0; + if (not sfo) then close(sf); + if (un<>0) then begin + reset(uf); + seek(uf,un); read(uf,user); + close(uf); + end; + end; + if (un<>0) then usernum:=un; + if ((user.deleted) or (not aacs1(user,usernum,acsreq))) then un:=0; + if (un=0) then begin + print('Invalid user account.'); nl; + printf('acseb'+cstr(eventnum)); + if (nofile) then begin + print('This time window allows certain other users to get online.'); + print('Please call back later, after it has ended.'); + end; + hangup:=TRUE; + end else begin + print('Valid user account - Welcome.'); + nl; + echo:=FALSE; + sprompt('Enter your password: '); input(pw,20); + if (pw<>user.pw) then begin + nl; + print('Invalid password. Hanging up.'); nl; + printf('acseb'+cstr(eventnum)); + if (nofile) then begin + print('This time window allows certain other users to get online.'); + print('Please call back later, after it has ended.'); + end; + hangup:=TRUE; + end else + nl; + echo:=TRUE; + end; + end; +end; + +function getuser:boolean; +var pw,s,phone,newusername,acsreq:astr; + lng:longint; + tries,i,ttimes,z,zz,eventnum:integer; + done,nu,ok,toomuch,wantnewuser,acsuser:boolean; +begin + wasnewuser:=FALSE; wasguestuser:=FALSE; + thisuser.tltoday:=15; { allow user 15 minutes to log on >MAX< } + extratime:=0.0; freetime:=0.0; choptime:=0.0; + with thisuser do begin + usernum:=-1; + name:='NO USER'; realname:='Not entered yet'; + sl:=0; dsl:=0; ar:=[]; + ac:=[onekey,pause,novice,color]; ac:=ac+systat.newac; + linelen:=80; pagelen:=25; + end; + getdatetime(timeon); + mread:=0; extratime:=0.0; freetime:=0.0; + realsl:=-1; realdsl:=-1; + newusername:=''; + + sl1(''); + s:=#3#3+'Logon '+#3#5+'['+dat+']'+#3#4+' ('; + if (spd<>'KB') then s:=s+spd+' baud)' else s:=s+'Keyboard)'; + sl1(s); + wantnewuser:=FALSE; + macok:=FALSE; nu:=FALSE; + echo:=TRUE; nl; + pw:=''; + + if (spd='300') then + begin + if (systat.lock300) then + begin + printf('no300.msg'); + if (nofile) then print('300 baud callers not allowed on this BBS.'); + hangup:=TRUE; + end; + if ((systat.b300lowtime<>0) or (systat.b300hitime<>0)) then + if (not intime(timer,systat.b300lowtime,systat.b300hitime)) then begin + printf('no300h.msg'); + if (nofile) then + print('300 baud calling hours are from '+ctim(systat.b300lowtime)+ + ' to '+ctim(systat.b300hitime)); + hangup:=TRUE; + end; + if (not hangup) then + if ((systat.b300lowtime<>0) or (systat.b300hitime<>0)) then begin + printf('yes300h.msg'); + if (nofile) then begin + print('NOTE: 300 baud calling times are'); + print('restricted to the following hours ONLY:'); + print(' '+ctim(systat.b300lowtime)+' to '+ctim(systat.b300hitime)); + end; + end; + end; + + acsuser:=FALSE; + for i:=0 to numevents do + with events[i]^ do + if ((etype='A') and (active) and (checkeventtime(i,0))) then begin + acsuser:=TRUE; + acsreq:=events[i]^.execdata; + eventnum:=i; + end; + + if (acsuser) then getacsuser(eventnum,acsreq); + + if ((systat.shuttlelog) and (not fastlogon) and (not hangup)) then doshuttle; + + nl; + pver; + if (not wantnewuser) and (not fastlogon) then begin + if pynq(fstring.ansiq) then thisuser.ac:=thisuser.ac+[ansi] + else thisuser.ac:=thisuser.ac-[ansi]; + thisuser.ac:=thisuser.ac-[avatar]; + printf('welcome'); + z:=0; + repeat + inc(z); + printf('welcome'+cstr(z)); + until (z=9) or (nofile) or (hangup); + end; + ttimes:=0; tries:=0; s:=''; + repeat + repeat + if (not wantnewuser) then begin + if (systat.multitask) then + print('[> System under Multitasking environment <]'); + if (fstring.note[1]<>'') then sprint(fstring.note[1]); + if (fstring.note[2]<>'') then sprint(fstring.note[2]); + if ((systat.guestuser<>-1) and (fstring.guestline<>'')) then + sprint(fstring.guestline); + if (fstring.lprompt<>'') then sprompt(fstring.lprompt); + end; + if (systat.shuttlelog) and (wantnewuser) then begin + s:=''; + usernum:=-1; + end else + finduser(s,usernum); + + if (pos('@',s)<>0) then begin + nl; + print('Nice try, idiot - that no longer works.'); + print('(SysOp has been notified.)'); + sl1('Idiot tried to gain illegal system info with @@ MCI usage at logon'); + hangup:=TRUE; + end; + + if (not hangup) then begin + nl; + newusername:=''; + if (usernum=0) then + if (s<>'') then begin + sprint(fstring.namenotfound); + if pynq('"'+s+'" - Log on as NEW? ') then usernum:=-1; + nl; + newusername:=s; + end else begin + inc(ttimes); + if (ttimes>systat.maxlogontries) then hangup:=TRUE; + end; + end; + until ((usernum<>0) or (hangup)); + ok:=TRUE; done:=FALSE; + if (not hangup) then + case usernum of + -1:begin + newuserinit(newusername); + nu:=TRUE; + done:=TRUE; ok:=FALSE; + end; + -2:begin + reset(uf); + usernum:=systat.guestuser; + if (usernum>filesize(uf)-1) then begin + sl1(#3#8+'>>'+#3#1+' Guest user account unavailable!'); + print('Guest user account unavailable.'); + print('SysOp will be notified.'); + hangup:=TRUE; + end else begin + seek(uf,systat.guestuser); read(uf,thisuser); + print('Terminal configuration:'); + cstuff(11,1,thisuser); + cstuff(3,1,thisuser); + nl; + print('As a guest user we ask that you enter a unique name for our system records.'); + cstuff(7,1,thisuser); + nl; + wasguestuser:=TRUE; done:=TRUE; + end; + close(uf); + end; + else + if (usernum=-3) then begin + nl; + print('Nice try, idiot - that no longer works.'); + print('(SysOp has been notified.)'); + sl1('Idiot tried to crash system with negative number entry at logon'); + hangup:=TRUE; + end else begin + reset(uf); + seek(uf,usernum); read(uf,thisuser); + echo:=FALSE; + if (not systat.localsec) then begin + if (not useron) then begin + useron:=TRUE; + schangewindow(TRUE,systat.curwindow); + end else + schangewindow(FALSE,systat.curwindow); + commandline('Password - "'+thisuser.pw+'"'); + useron:=FALSE; + end; + + getpws(ok,tries); + if (ok) then + begin + done:=TRUE; + readinmacros; readinzscan; + end; + + close(uf); + if (not ok) then begin + useron:=TRUE; sclearwindow; useron:=FALSE; + end; + end; + end; + until ((done) or (hangup)); + if ((thisuser.lockedout) and (not hangup)) then begin + printf(thisuser.lockedfile); + sysoplog(#3#7+'['+#3#8+'*'+#3#7+'] '+#3#3+thisuser.name+#3#7+' --> '+#3#5+ + 'Attempt to access system when locked out'+#3#7+' <--'); + hangup:=TRUE; + end; + if ((not nu) and (not hangup)) then + begin + toomuch:=FALSE; + if (thisuser.laston<>date) then begin + thisuser.ontoday:=0; + thisuser.tltoday:=systat.timeallow[thisuser.sl]; + end; + if (((rlogon in thisuser.ac) or (systat.callallow[thisuser.sl]=1)) and + (thisuser.ontoday>=1) and (thisuser.laston=date)) then begin + printf('2manycal'); + if (nofile) then print('You can only log on once per day.'); + toomuch:=TRUE; + end else + if ((thisuser.ontoday>=systat.callallow[thisuser.sl]) and + (thisuser.laston=date)) then begin + printf('2manycal'); + if (nofile) then + print('You can only log on '+cstr(systat.callallow[thisuser.sl])+' times per day.'); + toomuch:=TRUE; + end else + if ((thisuser.tltoday<=0) and (thisuser.laston=date)) then begin + printf('notlefta'); + if (nofile) then + prompt('You can only log on for '+cstr(systat.timeallow[thisuser.sl])+' minutes per day.'); + toomuch:=TRUE; + if (thisuser.timebank>0) then begin + nl; nl; + sprint(#3#5+'However, you have '+cstrl(thisuser.timebank)+ + ' minutes left in your Time Bank.'); + dyny:=TRUE; + if pynq('Withdraw from Time Bank? [Y] : ') then begin + prt('Withdraw how many minutes? '); inu(zz); lng:=zz; + if (lng>0) then begin + if (lng>thisuser.timebank) then lng:=thisuser.timebank; + dec(thisuser.timebankadd,lng); + if (thisuser.timebankadd<0) then thisuser.timebankadd:=0; + dec(thisuser.timebank,lng); + inc(thisuser.tltoday,lng); + sprint('^5In your account: ^3'+cstr(thisuser.timebank)+ + '^5 Time left online: ^3'+cstr(trunc(nsl) div 60)); + sysoplog('TimeBank: No time left at logon, withdrew '+cstrl(lng)+' minutes.'); + end; + end; + if (nsl>=0) then toomuch:=FALSE else sprint(#3#7+'Hanging up.'); + end; + end; + if (toomuch) then + begin + sl1(#3#7+' [*] '+#3#1+thisuser.name+' #'+cstr(usernum)+' tried logging on more than allowed.'); + hangup:=TRUE; + end; + if (tries=systat.maxlogontries) then hangup:=TRUE; + if (not hangup) then inc(thisuser.ontoday); + end; + checkit:=FALSE; + if ((usernum>0) and (not hangup)) then + begin + getuser:=nu; + useron:=TRUE; + schangewindow(not cwindowon,systat.curwindow); + commandline('- Successful Logon -'); + useron:=FALSE; + inittrapfile; + s:=#3#3+'Welcome to '+systat.bbsname+#3#3; + if (fidor.net<>0) then s:=s+' ('+cstr(fidor.zone)+':'+cstr(fidor.net)+'/'+ + cstr(fidor.node)+'.'+cstr(fidor.point)+')'; + s:=s+', '+nam; + nl; sprint(s); nl; + end; + if (hangup) then getuser:=FALSE; +end; + +end. diff --git a/logon2.pas b/logon2.pas new file mode 100644 index 0000000..0a088cb --- /dev/null +++ b/logon2.pas @@ -0,0 +1,495 @@ +(*****************************************************************************) +(*> <*) +(*> LOGON2 .PAS - Written by Eric Oman <*) +(*> <*) +(*> Logon functions -- Part 2. <*) +(*> <*) +(*> <*) +(*****************************************************************************) +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit logon2; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + mail0, mail1, mail2, mail3, mail4, mail9, + misc2, miscx, + cuser, + doors, + archive1, + menus, + common; + +procedure logon; +procedure logoff; +procedure endday; +procedure pver; + +implementation + +procedure logon; +var ul:text; + vdata:file of vdatar; + lcallf:file of lcallers; + u:userrec; + vd:vdatar; + lcall:lcallers; + lo:array[1..8] of astr; + s:astr; + zz:string[5]; + lng:longint; + num,lcts,hilc,vna,callsleft,ct,z,qq,rcode:integer; + c:char; + abort,lastinit:boolean; + datet:string; + h, m, x: Word; + + procedure day_desc(dat:astr); + var d:astr; + hs:boolean; + + procedure p(s:astr); + begin + sprompt(s); + hs:=TRUE; + end; + + begin + hs:=FALSE; d:=copy(date,1,5); + if (d='01/01') then p('Happy New Year') else + if (d='07/04') then p('Happy '+#3#7+'4th '+#3#0+'of '+#3#4+'July'+#3#3) else + if (d='12/24') then p('Happy Christmas Eve') else + if (d='12/25') then p(#3#9+'Merry '+#3#7+'Christmas'+#3#3); + + if (not hs) then + begin + if (timer<21600) or (timer>=64800) then p('Good evening') else + if (timer<43200) and (timer>=21600) then p('Good morning') else + p('Good afternoon'); + end; + end; + + function checkbday:boolean; + var i,j:integer; + begin + i:=85; + repeat + j:=daynum(copy(thisuser.bday,1,6)+tch(cstr(i))); + if (daynum(date)>=j) and (daynum(thisuser.laston)value(copy(date,7,2))); + checkbday:=FALSE; + end; + + function bsince:boolean; + begin + bsince:=(not (copy(thisuser.bday,1,5)=copy(date,1,5))); + end; + + procedure showbday(s:astr); + begin + nofile:=TRUE; + if (bsince) then printf('bdys'+s); {* birthday occured SINCE laston *} + if (nofile) then printf('bday'+s); {* birthday TODAY *} + end; + + procedure findchoptime; + var lng,lng2,lng3:longint; + + procedure onlinetime; + var dt:datetimerec; + secs:longint; + begin + secs:=trunc(nsl); + dt.day:=secs div 86400; secs:=secs-(dt.day*86400); + dt.hour:=secs div 3600; secs:=secs-(dt.hour*3600); + dt.min:=secs div 60; secs:=secs-(dt.min*60); + dt.sec:=secs; + sprint(^G); + sprint(#3#8+'** '+#3#5+'System event approaching - online time adjusted to:'); + sprint(#3#8+'** '+#3#0+longtim(dt)); + sprint(^G); + end; + + begin + if (exteventtime<>0) then + begin + lng:=exteventtime; + if (lng180) then lng2:=180; + while (lng<=lng2) do + begin + lng3:=lng*60; + if (checkevents(lng3)<>0) then + begin + choptime:=(nsl-(lng*60.0))+60.0; onlinetime; exit; + end; + inc(lng,2); + end; + end; + +begin + getdatetime(timeon); mread:=0; extratime:=0.0; freetime:=0.0; + useron:=TRUE; com_flush_rx; logon1st; + + if ((thisuser.sl=255) and (not fastlogon) and (spd<>'KB')) then + begin + if pynq('Fast logon? ') then fastlogon:=TRUE; + nl; + end; + + lastinit:=FALSE; assign(lcallf,systat.gfilepath+'laston.dat'); + {$I-} reset(lcallf); {$I+} + if (ioresult<>0) then + begin + lastinit:=TRUE; rewrite(lcallf); lcall.callernum:=-1; + for z:=0 to 9 do write(lcallf,lcall); + end; + if (systat.lcallinlogon) then + begin + if (cso) then lcts:=10 else lcts:=4; + lcall.callernum:=0; z:=0; hilc:=9; + for z:=0 to 9 do + begin + seek(lcallf,z); read(lcallf,lcall); + if (lcall.callernum=-1) and (hilc=9) then hilc:=z-1; + end; + if (hilc<>-1) then + begin + if (not cso) and (hilc>3) then hilc:=3; + sprint(#3#5+'Last few callers:'); + for z:=hilc downto 0 do + begin + seek(lcallf,z); read(lcallf,lcall); + with lcall do + sprint(#3#3+cstr(callernum)+': '+#3#0+name+ + #3#2+' #'+#3#4+cstr(number)+#3#3+' from '+#3#0+citystate+#3#3+' at '+#3#4+datet); + end; + end; + nl; + end; + if ((spd<>'KB') or (lastinit)) then + begin + for z:=9 downto 1 do + begin + seek(lcallf,z-1); read(lcallf,lcall); + seek(lcallf,z); write(lcallf,lcall); + end; + with lcall do + begin + callernum:=systat.callernum; name:=caps(thisuser.name); + number:=usernum; citystate:=thisuser.citystate; + datet:=dat; + end; + seek(lcallf,0); write(lcallf,lcall); + end; + close(lcallf); + + if ((not fastlogon) and (not hangup)) then + begin + printf('logon'); pausescr; nofile:=FALSE; z:=0; + repeat + inc(z); printf('logon'+cstr(z)); + until (z=9) or (nofile) or (hangup); + + printf('sl'+cstr(thisuser.sl)); + printf('dsl'+cstr(thisuser.dsl)); + for c:='A' to 'Z' do + if (c in thisuser.ar) then printf('arlevel'+c); + printf('user'+cstr(usernum)); + + if (checkbday) then + begin + showbday(cstr(usernum)); + if nofile then showbday(''); + if nofile then + if bsince then begin + sprint(#3#4+'-------------------------------------------------------------------'); + sprint(#3#3+'Happy Birthday, '+caps(thisuser.name)+' !!!'); + sprint(#3#3+'You turned '+cstr(ageuser(thisuser.bday))+' on '+ + copy(thisuser.bday,1,5)+copy(date,6,3)+'!!'); + sprint(#3#3+'(a little late, but it''s the thought that counts!)'); + sprint(#3#4+'-------------------------------------------------------------------'); + nl; + end else begin + sprint(#3#4+'-------------------------------------------------------------------'); + sprint(#3#3+'Happy Birthday, '+caps(thisuser.name)+' !!!'); + sprint(#3#3+'You turned '+cstr(ageuser(thisuser.bday))+' today!!'); + sprint(#3#4+'-------------------------------------------------------------------'); + nl; + end; + end; + + if (exist('logon.bat')) then + begin + shelldos(FALSE,process_door('logon.bat @F @L @B @G @T @R'),rcode); + topscr; + end; + nl; cl(5); + if (sysop) then sprint(fstring.sysopin) else sprint(fstring.sysopout); + if (systat.autominlogon) then readamsg; + nl; + end; + + if (not wasguestuser) then + begin + if (thisuser.flistopt=0) then thisuser.flistopt:=1; + if (thisuser.bday='00/00/00') then begin + print('Updating system records ...'); + cstuff(2,1,thisuser); + nl; + end; + if (thisuser.citystate='') or (thisuser.citystate='Unknown, MI') then + cstuff(4,1,thisuser); + if (thisuser.clsmsg=0) then + begin + nl; + print('Updating user account ... Do you prefer:'); + nl; + print(' (1.) A clear-screen before each message'); + print(' (2.) Continuous listing of messages, with no screen clearing.'); + nl; + prt('Enter selection: '); onek(c,'12'); + if (not hangup) then + if (c='1') then thisuser.clsmsg:=1 else thisuser.clsmsg:=2; + end; + if (thisuser.avadjust=0) then + begin + thisuser.avadjust:=1; + thisuser.ac:=thisuser.ac-[avatar]; + end; + end; + + if (thisuser.computer='Unknown') then + begin + cstuff(5,1,thisuser); nl; + end; + savesystat; + + with thisuser do + begin + if ((not fastlogon) and (not hangup)) then begin + if (systat.yourinfoinlogon) then begin pausescr; yourinfo; nl; end; + cl(3); day_desc(dat); sprint(', '+nam+'.'); + nl; + sprint(#3#3+'You are caller '+#3#4+'#'+#3#0+cstr(systat.callernum)+','); + if (systat.todayzlog.calls<>0) then + begin + sprompt(#3#3+'the '); + zz:=cstr(systat.todayzlog.calls); zz:=copy(zz,length(zz),1); + z:=value(zz); ct:=systat.todayzlog.calls; + if (ct in [11..13]) then z:=4; + sprompt(#3#0+cstr(systat.todayzlog.calls)+#3#4); + case z of + 1:sprompt('st'); + 2:sprompt('nd'); + 3:sprompt('rd'); + else + sprompt('th'); + end; + sprint(#3#3+' caller for today.'); + end; + + nl; + lmsg:=FALSE; + + sprint('Time allowed - '+#3#3+cstr(systat.timeallow[thisuser.sl])+' minutes'); + if (waiting<>0) then + begin + sprompt('Mail waiting - '+#3#3+cstr(waiting)+' letter'); + if (waiting>1) then print('s') else nl; + end; + if (illegal<>0) then + sprint(^G+#3#8+'Illegal logons - '+cstr(illegal)+' attempts '); + if (loggedon<>0) then + sprint('You have called - '+#3#3+cstr(loggedon)+' times'); + if (laston<>date) then + sprint('Last on - '+#3#3+laston) + else + sprint('Calls today - '+#3#3+cstr(ontoday)+' times'); + sprompt('Account limits - '+#3#3+cstr(systat.callallow[thisuser.sl])+' call'); + if (systat.callallow[thisuser.sl]<>1) then sprompt('s'); + sprompt(', using a maximum of '+cstr(systat.timeallow[thisuser.sl])+' minutes, '); + if TRUE {*****} then sprint('per day.') else sprint('per call.'); + nl; + + if (daynum(laston)<=daynum(systat.tfiledate)) and + (daynum(laston)>0) then + begin + sprint(#3#5+'There may be new text files available.'); + end; + + vna:=0; + assign(vdata,systat.gfilepath+'voting.dat'); + {$I-} reset(vdata); {$I+} + if (ioresult=0) then begin + for num:=1 to 20 do begin + seek(vdata,num-1); read(vdata,vd); + if (vd.numa<>0) then + if (vote[num]=0) then inc(vna); + end; + close(vdata); + if (vna>0) then + begin + sprompt(#3#5+'You have not voted on '+#3#9+cstr(vna)+#3#5+' voting question'); + if (vna>1) then sprint('s.') else sprint('.'); + if (systat.forcevoting) and (not (rvoting in thisuser.ac)) then begin + nl; + while (not empty) do getkey(c); + pausescr; + misc1.vote; + end; + end; + end; + + if (forusr<>0) then + sprint(#3#7+'Your mail is being forwarded to user #'+cstr(forusr)); + nl; + topscr; + end; + end; + + findchoptime; + + with thisuser do + begin + if (smw in ac) then begin rsm; nl; end; + ac:=ac-[smw]; + if ((alert in ac) and (sysop)) then chatcall:=TRUE; + if (waiting<>0) then begin + if pynq('Read your mail now? ') then readmail; + nl; + end; + end; + if ((not fastlogon) and (systat.bullinlogon)) then bulletins(''); + + fastlogon:=FALSE; +end; + +procedure logoff; +var ddt,dt:datetimerec; + i,tt,rcode:integer; +begin + if ((useron) and (usernum>0)) then + if (exist('logoff.bat')) then + shelldos(FALSE,process_door('logoff.bat @F @L @B @G @T @R'),rcode); + + term_ready(FALSE); + + if ((useron) and (usernum>0)) then + begin + purgedir(systat.temppath+'1\'); + purgedir(systat.temppath+'2\'); + purgedir(systat.temppath+'3\'); + + slogging:=TRUE; + + if (trapping) then + begin + if (hungup) then + begin + writeln(trapfile); + writeln(trapfile,'NO CARRIER'); + end; + close(trapfile); trapping:=FALSE; + end; + + getdatetime(dt); timediff(ddt,timeon,dt); tt:=trunc((dt2r(ddt)+30)/60); + + thisuser.laston:=systat.lastdate; inc(thisuser.loggedon); + + (* if not logged in, but logged on *) + if (realsl<>-1) then thisuser.sl:=realsl; + if (realdsl<>-1) then thisuser.dsl:=realdsl; + + thisuser.illegal:=0; thisuser.ttimeon:=thisuser.ttimeon+tt; + if (choptime<>0.0) then inc(thisuser.tltoday,trunc(choptime/60.0)); + thisuser.tltoday:=trunc(nsl/60.0); + thisuser.lastmsg:=board; thisuser.lastfil:=fileboard; + + reset(uf); + if ((usernum>=1) and (usernum<=filesize(uf)-1)) then + begin seek(uf,usernum); write(uf,thisuser); end; + close(uf); + + if (spd<>'KB') then inc(systat.todayzlog.active,tt); + inc(systat.todayzlog.fback,ftoday); + inc(systat.todayzlog.privpost,etoday); + savesystat; + + for i:=1 to hiubatchv do release(ubatchv[i]); {* release dynamic memory *} + window(1,1,80,25); clrscr; + if (hungup) then sl1(#3#7+'>>*>*>*> Hung Up <*<*<*<<'); + sl1(#3#4+'Read: '+#3#3+cstr(mread)+#3#4+' / Time on: '+#3#3+cstr(tt)); + end; +end; + +procedure endday; +var d,i,tu,fu:integer; +begin + useron:=FALSE; + d:=daynum(date); + if (d<>ldate) then + if (d-ldate)=1 then + inc(ldate) + else begin + writeln('Date corrupted.'); + halt(1); + end; + +(***** + reset(mailfile); + for i:=0 to filesize(mailfile)-1 do begin + seek(mailfile,i); read(mailfile,mr); + if (old(mr.date,mr.mage) and (mr.destin<>-1)) then begin + fu:=abs(mr.from); + is:=rmail(i); + ssm(fu,is+' never got your letter.'); + end; + end; + close(mailfile); + reset(uf); + for board:=1 to numboards do begin + iscan; + cn:=1; + while (cn<=tnum) do begin + if (old(mary[cn].date,mary[cn].mage)) or + (mary[cn].messagestat=deleted) then + deletem(cn) + else + inc(cn); + end; + savebase; + end; + close(uf); + *****) +end; + +procedure pver; +var abort,next,aa:boolean; +begin + abort:=FALSE; next:=FALSE; + aa:=allowabort; allowabort:=FALSE; + + nl; + printacr(verline(1),abort,next); + printacr(verline(2),abort,next); + nl; + + allowabort:=aa; +end; + +end. diff --git a/logon2.~pa b/logon2.~pa new file mode 100644 index 0000000..9601cfb --- /dev/null +++ b/logon2.~pa @@ -0,0 +1,492 @@ +(*****************************************************************************) +(*> <*) +(*> LOGON2 .PAS - Written by Eric Oman <*) +(*> <*) +(*> Logon functions -- Part 2. <*) +(*> <*) +(*> <*) +(*****************************************************************************) +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit logon2; + +interface + +uses + crt, dos, overlay, + mail0, mail1, mail2, mail3, mail4, mail9, + misc2, miscx, + cuser, + doors, + archive1, + menus, + common; + +procedure logon; +procedure logoff; +procedure endday; +procedure pver; + +implementation + +procedure logon; +var ul:text; + vdata:file of vdatar; + lcallf:file of lcallers; + u:userrec; + vd:vdatar; + lcall:lcallers; + lo:array[1..8] of astr; + s:astr; + zz:string[5]; + lng:longint; + num,lcts,hilc,vna,callsleft,ct,z,qq,rcode:integer; + c:char; + abort,lastinit:boolean; + + procedure day_desc(dat:astr); + var d:astr; + hs:boolean; + + procedure p(s:astr); + begin + sprompt(s); + hs:=TRUE; + end; + + begin + hs:=FALSE; d:=copy(date,1,5); + if (d='01/01') then p('Happy New Year') else + if (d='07/04') then p('Happy '+#3#7+'4th '+#3#0+'of '+#3#4+'July'+#3#3) else + if (d='12/24') then p('Happy Christmas Eve') else + if (d='12/25') then p(#3#9+'Merry '+#3#7+'Christmas'+#3#3) + if (d='01/23') then + p(#3#9+'Happy Birthday '+#3+#7+'Robert Shady'+#3+#9+' (An Author of TeleGard-X!)') + else if (d='04/01') then + p(#3#9+'Happy Birthday '+#3+#7+'Scott Deming'+#3+#9+' (An Author of TeleGard-X!)'); + + if (not hs) then + begin + if (timer<21600) or (timer>=64800) then p('Good evening') else + if (timer<43200) and (timer>=21600) then p('Good morning') else + p('Good afternoon'); + end; + end; + + function checkbday:boolean; + var i,j:integer; + begin + i:=85; + repeat + j:=daynum(copy(thisuser.bday,1,6)+tch(cstr(i))); + if (daynum(date)>=j) and (daynum(thisuser.laston)value(copy(date,7,2))); + checkbday:=FALSE; + end; + + function bsince:boolean; + begin + bsince:=(not (copy(thisuser.bday,1,5)=copy(date,1,5))); + end; + + procedure showbday(s:astr); + begin + nofile:=TRUE; + if (bsince) then printf('bdys'+s); {* birthday occured SINCE laston *} + if (nofile) then printf('bday'+s); {* birthday TODAY *} + end; + + procedure findchoptime; + var lng,lng2,lng3:longint; + + procedure onlinetime; + var dt:datetimerec; + secs:longint; + begin + secs:=trunc(nsl); + dt.day:=secs div 86400; secs:=secs-(dt.day*86400); + dt.hour:=secs div 3600; secs:=secs-(dt.hour*3600); + dt.min:=secs div 60; secs:=secs-(dt.min*60); + dt.sec:=secs; + sprint(^G); + sprint(#3#8+'** '+#3#5+'System event approaching - online time adjusted to:'); + sprint(#3#8+'** '+#3#0+longtim(dt)); + sprint(^G); + end; + + begin + if (exteventtime<>0) then + begin + lng:=exteventtime; + if (lng180) then lng2:=180; + while (lng<=lng2) do + begin + lng3:=lng*60; + if (checkevents(lng3)<>0) then + begin + choptime:=(nsl-(lng*60.0))+60.0; onlinetime; exit; + end; + inc(lng,2); + end; + end; + +begin + getdatetime(timeon); mread:=0; extratime:=0.0; freetime:=0.0; + useron:=TRUE; com_flush_rx; logon1st; + + if ((thisuser.sl=255) and (not fastlogon) and (spd<>'KB')) then + begin + if pynq('Fast logon? ') then fastlogon:=TRUE; + nl; + end; + + lastinit:=FALSE; assign(lcallf,systat.gfilepath+'laston.dat'); + {$I-} reset(lcallf); {$I+} + if (ioresult<>0) then + begin + lastinit:=TRUE; rewrite(lcallf); lcall.callernum:=-1; + for z:=0 to 9 do write(lcallf,lcall); + end; + if (systat.lcallinlogon) then + begin + if (cso) then lcts:=10 else lcts:=4; + lcall.callernum:=0; z:=0; hilc:=9; + for z:=0 to 9 do + begin + seek(lcallf,z); read(lcallf,lcall); + if (lcall.callernum=-1) and (hilc=9) then hilc:=z-1; + end; + if (hilc<>-1) then + begin + if (not cso) and (hilc>3) then hilc:=3; + sprint(#3#5+'Last few callers:'); + for z:=hilc downto 0 do + begin + seek(lcallf,z); read(lcallf,lcall); + with lcall do + sprint(#3#3+cstr(callernum)+': '+#3#0+name+ + #3#2+' #'+#3#4+cstr(number)+#3#3+' from '+#3#0+citystate); + end; + end; + nl; + end; + if ((spd<>'KB') or (lastinit)) then + begin + for z:=9 downto 1 do + begin + seek(lcallf,z-1); read(lcallf,lcall); + seek(lcallf,z); write(lcallf,lcall); + end; + with lcall do + begin + callernum:=systat.callernum; name:=caps(thisuser.name); + number:=usernum; citystate:=thisuser.citystate; + end; + seek(lcallf,0); write(lcallf,lcall); + end; + close(lcallf); + + if ((not fastlogon) and (not hangup)) then + begin + printf('logon'); pausescr; nofile:=FALSE; z:=0; + repeat + inc(z); printf('logon'+cstr(z)); + until (z=9) or (nofile) or (hangup); + + printf('sl'+cstr(thisuser.sl)); + printf('dsl'+cstr(thisuser.dsl)); + for c:='A' to 'Z' do + if (c in thisuser.ar) then printf('arlevel'+c); + printf('user'+cstr(usernum)); + + if (checkbday) then + begin + showbday(cstr(usernum)); + if nofile then showbday(''); + if nofile then + if bsince then begin + sprint(#3#4+'-------------------------------------------------------------------'); + sprint(#3#3+'Happy Birthday, '+caps(thisuser.name)+' !!!'); + sprint(#3#3+'You turned '+cstr(ageuser(thisuser.bday))+' on '+ + copy(thisuser.bday,1,5)+copy(date,6,3)+'!!'); + sprint(#3#3+'(a little late, but it''s the thought that counts!)'); + sprint(#3#4+'-------------------------------------------------------------------'); + nl; + end else begin + sprint(#3#4+'-------------------------------------------------------------------'); + sprint(#3#3+'Happy Birthday, '+caps(thisuser.name)+' !!!'); + sprint(#3#3+'You turned '+cstr(ageuser(thisuser.bday))+' today!!'); + sprint(#3#4+'-------------------------------------------------------------------'); + nl; + end; + end; + + if (exist('logon.bat')) then + begin + shelldos(FALSE,process_door('logon.bat @F @L @B @G @T @R'),rcode); + topscr; + end; + nl; cl(5); + if (sysop) then sprint(fstring.sysopin) else sprint(fstring.sysopout); + if (systat.autominlogon) then readamsg; + nl; + end; + + if (not wasguestuser) then + begin + if (thisuser.flistopt=0) then thisuser.flistopt:=1; + if (thisuser.bday='00/00/00') then begin + print('Updating system records ...'); + cstuff(2,1,thisuser); + nl; + end; + if (thisuser.citystate='') or (thisuser.citystate='Unknown, MI') then + cstuff(4,1,thisuser); + if (thisuser.clsmsg=0) then + begin + nl; + print('Updating user account ... Do you prefer:'); + nl; + print(' (1.) A clear-screen before each message'); + print(' (2.) Continuous listing of messages, with no screen clearing.'); + nl; + prt('Enter selection: '); onek(c,'12'); + if (not hangup) then + if (c='1') then thisuser.clsmsg:=1 else thisuser.clsmsg:=2; + end; + if (thisuser.avadjust=0) then + begin + thisuser.avadjust:=1; + thisuser.ac:=thisuser.ac-[avatar]; + end; + end; + + if (thisuser.computer='Unknown') then + begin + cstuff(5,1,thisuser); nl; + end; + savesystat; + + with thisuser do + begin + if ((not fastlogon) and (not hangup)) then begin + if (systat.yourinfoinlogon) then begin pausescr; yourinfo; nl; end; + cl(3); day_desc(dat); sprint(', '+nam+'.'); + nl; + sprint(#3#3+'You are caller '+#3#4+'#'+#3#0+cstr(systat.callernum)+','); + if (systat.todayzlog.calls<>0) then + begin + sprompt(#3#3+'the '); + zz:=cstr(systat.todayzlog.calls); zz:=copy(zz,length(zz),1); + z:=value(zz); ct:=systat.todayzlog.calls; + if (ct in [11..13]) then z:=4; + sprompt(#3#0+cstr(systat.todayzlog.calls)+#3#4); + case z of + 1:sprompt('st'); + 2:sprompt('nd'); + 3:sprompt('rd'); + else + sprompt('th'); + end; + sprint(#3#3+' caller for today.'); + end; + + nl; + lmsg:=FALSE; + + sprint('Time allowed - '+#3#3+cstr(systat.timeallow[thisuser.sl])+' minutes'); + if (waiting<>0) then + begin + sprompt('Mail waiting - '+#3#3+cstr(waiting)+' letter'); + if (waiting>1) then print('s') else nl; + end; + if (illegal<>0) then + sprint(^G+#3#8+'Illegal logons - '+cstr(illegal)+' attempts '); + if (loggedon<>0) then + sprint('You have called - '+#3#3+cstr(loggedon)+' times'); + if (laston<>date) then + sprint('Last on - '+#3#3+laston) + else + sprint('Calls today - '+#3#3+cstr(ontoday)+' times'); + sprompt('Account limits - '+#3#3+cstr(systat.callallow[thisuser.sl])+' call'); + if (systat.callallow[thisuser.sl]<>1) then sprompt('s'); + sprompt(', using a maximum of '+cstr(systat.timeallow[thisuser.sl])+' minutes, '); + if TRUE {*****} then sprint('per day.') else sprint('per call.'); + nl; + + if (daynum(laston)<=daynum(systat.tfiledate)) and + (daynum(laston)>0) then + begin + sprint(#3#5+'There may be new text files available.'); + end; + + vna:=0; + assign(vdata,systat.gfilepath+'voting.dat'); + {$I-} reset(vdata); {$I+} + if (ioresult=0) then begin + for num:=1 to 20 do begin + seek(vdata,num-1); read(vdata,vd); + if (vd.numa<>0) then + if (vote[num]=0) then inc(vna); + end; + close(vdata); + if (vna>0) then + begin + sprompt(#3#5+'You have not voted on '+#3#9+cstr(vna)+#3#5+' voting question'); + if (vna>1) then sprint('s.') else sprint('.'); + if (systat.forcevoting) and (not (rvoting in thisuser.ac)) then begin + nl; + while (not empty) do getkey(c); + pausescr; + misc1.vote; + end; + end; + end; + + if (forusr<>0) then + sprint(#3#7+'Your mail is being forwarded to user #'+cstr(forusr)); + nl; + topscr; + end; + end; + + findchoptime; + + with thisuser do + begin + if (smw in ac) then begin rsm; nl; end; + ac:=ac-[smw]; + if ((alert in ac) and (sysop)) then chatcall:=TRUE; + if (waiting<>0) then begin + if pynq('Read your mail now? ') then readmail; + nl; + end; + end; + if ((not fastlogon) and (systat.bullinlogon)) then bulletins(''); + + fastlogon:=FALSE; +end; + +procedure logoff; +var ddt,dt:datetimerec; + i,tt,rcode:integer; +begin + if ((useron) and (usernum>0)) then + if (exist('logoff.bat')) then + shelldos(FALSE,process_door('logoff.bat @F @L @B @G @T @R'),rcode); + + term_ready(FALSE); + + if ((useron) and (usernum>0)) then + begin + purgedir(systat.temppath+'1\'); + purgedir(systat.temppath+'2\'); + purgedir(systat.temppath+'3\'); + + slogging:=TRUE; + + if (trapping) then + begin + if (hungup) then + begin + writeln(trapfile); + writeln(trapfile,'NO CARRIER'); + end; + close(trapfile); trapping:=FALSE; + end; + + getdatetime(dt); timediff(ddt,timeon,dt); tt:=trunc((dt2r(ddt)+30)/60); + + thisuser.laston:=systat.lastdate; inc(thisuser.loggedon); + + (* if not logged in, but logged on *) + if (realsl<>-1) then thisuser.sl:=realsl; + if (realdsl<>-1) then thisuser.dsl:=realdsl; + + thisuser.illegal:=0; thisuser.ttimeon:=thisuser.ttimeon+tt; + if (choptime<>0.0) then inc(thisuser.tltoday,trunc(choptime/60.0)); + thisuser.tltoday:=trunc(nsl/60.0); + thisuser.lastmsg:=board; thisuser.lastfil:=fileboard; + + reset(uf); + if ((usernum>=1) and (usernum<=filesize(uf)-1)) then + begin seek(uf,usernum); write(uf,thisuser); end; + close(uf); + + if (spd<>'KB') then inc(systat.todayzlog.active,tt); + inc(systat.todayzlog.fback,ftoday); + inc(systat.todayzlog.privpost,etoday); + savesystat; + + for i:=1 to hiubatchv do release(ubatchv[i]); {* release dynamic memory *} + window(1,1,80,25); clrscr; + if (hungup) then sl1(#3#7+'>>*>*>*> Hung Up <*<*<*<<'); + sl1(#3#4+'Read: '+#3#3+cstr(mread)+#3#4+' / Time on: '+#3#3+cstr(tt)); + end; +end; + +procedure endday; +var d,i,tu,fu:integer; +begin + useron:=FALSE; + d:=daynum(date); + if (d<>ldate) then + if (d-ldate)=1 then + inc(ldate) + else begin + writeln('Date corrupted.'); + halt(1); + end; + +(***** + reset(mailfile); + for i:=0 to filesize(mailfile)-1 do begin + seek(mailfile,i); read(mailfile,mr); + if (old(mr.date,mr.mage) and (mr.destin<>-1)) then begin + fu:=abs(mr.from); + is:=rmail(i); + ssm(fu,is+' never got your letter.'); + end; + end; + close(mailfile); + reset(uf); + for board:=1 to numboards do begin + iscan; + cn:=1; + while (cn<=tnum) do begin + if (old(mary[cn].date,mary[cn].mage)) or + (mary[cn].messagestat=deleted) then + deletem(cn) + else + inc(cn); + end; + savebase; + end; + close(uf); + *****) +end; + +procedure pver; +var abort,next,aa:boolean; +begin + abort:=FALSE; next:=FALSE; + aa:=allowabort; allowabort:=FALSE; + + nl; + printacr(verline(1),abort,next); + printacr(verline(2),abort,next); + nl; + + allowabort:=aa; +end; + +end. diff --git a/mabs.pas b/mabs.pas new file mode 100644 index 0000000..6cadd65 --- /dev/null +++ b/mabs.pas @@ -0,0 +1,268 @@ +uses dos, + mdek,timejunk; + +(* + Execution method: + MABS [site type] [[site info file] [serial number]] +*) + +type infoheaderrec=array[1..6] of byte; + +const infoheader:infoheaderrec=($FA,$CD,$20,$EF,$02,$AA); + +var siteinfof:text; + f:file; + pdt:packdatetime; + pstr:array[1..20] of string; + s,siteinfofile,siteinfos,oversiteinfo:string; + r:array[1..144] of byte; + lng,serialnumber:longint; + chk,chk1,chk2:word; + res,i,pcount,wanttype:integer; + c:char; + vertypes:byte; + b,notcoded:boolean; + +function stripcolor(o:string):string; +var s:string; + i:integer; + lc:boolean; +begin + s:=''; lc:=FALSE; + for i:=1 to length(o) do + if (lc) then lc:=FALSE + else if ((o[i]=#3) or (o[i]='^')) then lc:=TRUE else s:=s+o[i]; + stripcolor:=s; +end; + +procedure decryptinfo; +var s:string; + i:integer; +begin + for i:=13 to 142 do s[i-12]:=chr(r[i]); s[0]:=chr(132); + s:=decrypt(s,r[7],r[8],r[9],r[10],r[11],r[12]); + for i:=13 to 142 do r[i]:=ord(s[i-12]); +end; + +procedure encryptinfo; +var s:string; + i:integer; +begin + for i:=13 to 142 do s[i-12]:=chr(r[i]); s[0]:=chr(132); + s:=encrypt(s,r[7],r[8],r[9],r[10],r[11],r[12]); + for i:=13 to 142 do r[i]:=ord(s[i-12]); +end; + +procedure maketruerandom; +var dt:ldatetimerec; + ll,ll2:longint; +begin + getdatetime(dt); + with dt do + ll:=(year-1980)+month+day*hour*min*sec*sec100; + randseed:=ll; +end; + +function aonoff(b:boolean; s1,s2:string):string; +begin + if (b) then aonoff:=s1 else aonoff:=s2; +end; + +begin + maketruerandom; + + siteinfofile:=''; oversiteinfo:=''; + wanttype:=-1; serialnumber:=0; + + pcount:=paramcount; + for i:=1 to pcount do pstr[i]:=paramstr(i); + + {$IFDEF AS1} + pstr[1]:='9'; pstr[2]:='***'; pstr[3]:='1'; pcount:=3; + oversiteinfo:='Eric Oman'+^J+#3#7+'Grosse '+#3#0+'Pointe '+#3#4+'Centrale'+ + ^J+#3#7+'313-'+#3#0+'885-'+#3#4+'1779'+^J; + {$ELSE} + {$IFDEF AS2} + pstr[1]:='1'; pstr[2]:='***'; pstr[3]:='2'; pcount:=3; + oversiteinfo:='Todd Bolitho'+^J+'Warp Speed BBS'+^J+'313-544-0405'+^J; + {$ELSE} + {$IFDEF AS3} + pstr[1]:='1'; pstr[2]:='***'; pstr[3]:='3'; pcount:=3; + oversiteinfo:='Martin Pollard'+^J+'The I/O Bus'+^J+'313-755-7786'+^J; + {$ELSE} + {$IFDEF AS4} + pstr[1]:='1'; pstr[2]:='***'; pstr[3]:='4'; pcount:=3; + oversiteinfo:='John Dixon (Nikademus)'+^J+'The Ozone BBS'+^J+ + '313-689-2876'+^J; + {ELSE} + {$IFDEF AS5} + pstr[1]:='1'; pstr[2]:='***'; pstr[3]:='5'; pcount:=3; + oversiteinfo:='Bill Schwartz'+^J+'Electric Eye II BBS'+^J+ + '313-776-8928'+^J; + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + + if (pcount>=1) then begin + val(pstr[1],wanttype,i); + if (pcount>=2) then + if (pstr[2]='***') then + siteinfofile:='***' + else begin + siteinfofile:=pstr[2]; + assign(f,siteinfofile); + {$I-} reset(f); {$I+} + if (ioresult<>0) then begin + writeln; + writeln(siteinfofile+': File not found.'); + halt(1); + end else + close(f); + end; + if (pcount>=3) then val(pstr[3],serialnumber,i); + end; + + assign(f,'bbs.ovr'); + {$I-} reset(f,1); {$I+} + if (ioresult<>0) then begin + writeln; + writeln('BBS files not found.'); + halt(1); + end; + seek(f,filesize(f)-144); + blockread(f,r,144,res); + close(f); + if (res<>144) then writeln('Errors reading in current data'); + + notcoded:=FALSE; + for i:=1 to 6 do + if (r[i]<>infoheader[i]) then notcoded:=TRUE; + + if (not notcoded) then decryptinfo; + + if (wanttype=-1) then begin + serialnumber:=r[20]+r[21] shl 8+r[22] shl 16+r[23] shl 24; + vertypes:=r[19]; + c:=#0; + repeat + if (c<>'?') then begin + writeln; + write('Version type = '); + case (vertypes and $07) of + $00:writeln('Standard'); + $01:writeln('Alpha'); $02:writeln('Beta'); + $03:writeln('Gamma'); $04:writeln('Special'); + else writeln('Unknown! (',vertypes,')'); + end; + writeln('Serial number = ',serialnumber); + writeln('Registration = '+aonoff((vertypes and $08=$08),'Yes','No')); + writeln('Node membership = '+aonoff((vertypes and $10=$10),'Yes','No')); + writeln; + end; + write('[>'); readln(s); c:=upcase(s[1]); + if (s<>'') then + case c of + '0'..'4': + begin + vertypes:=vertypes and ($FF-$07); + case c of + '1':vertypes:=vertypes or $01; + '2':vertypes:=vertypes or $02; + '3':vertypes:=vertypes or $03; + '4':vertypes:=vertypes or $04; + '5':vertypes:=vertypes or $05; + end; + end; + '#':if (length(s)<>1) then begin + s:=copy(s,2,length(s)-1); val(s,lng,i); + serialnumber:=lng; + end; + '$':begin + b:=vertypes and $08=$08; + if (b) then vertypes:=vertypes and ($FF-$08) + else vertypes:=vertypes or $08; + end; + '@':begin + b:=vertypes and $10=$10; + if (b) then vertypes:=vertypes and ($FF-$10) + else vertypes:=vertypes or $10; + end; + '?':begin + writeln; + writeln('0:Standard'); + writeln('1:Alpha - "à"'); + writeln('2:Beta - "á"'); + writeln('3:Gamma - "â"'); + writeln('4:Special - "ä"'); + writeln('#xxxxx:Change serial number'); + writeln('$:Toggle registration'); + writeln('@:Toggle node membership'); + writeln; + writeln('R:elist'); + writeln; + end; + end; + until ((s='') or (c='Q')); + end else + vertypes:=wanttype; + + for i:=1 to 6 do r[i]:=infoheader[i]; + r[19]:=vertypes; + + reset(f,1); + if (notcoded) then seek(f,filesize(f)) + else seek(f,filesize(f)-144); + + getpackdatetime(@pdt); + r[13]:=pdt[1]; r[14]:=pdt[2]; r[15]:=pdt[3]; + r[16]:=pdt[4]; r[17]:=pdt[5]; r[18]:=pdt[6]; + + r[20]:=(serialnumber and $FF); + r[21]:=((serialnumber and $FF00) shr 8); + r[22]:=((serialnumber and $FF0000) shr 16); + r[23]:=((serialnumber and $FF000000) shr 24); + + siteinfos:=''; + if (siteinfofile<>'') then + if (oversiteinfo<>'') then begin + siteinfos:=oversiteinfo; + s:=''; + for i:=1 to length(oversiteinfo) do + if (oversiteinfo[i]=^J) then s:=s+^M^J + else s:=s+oversiteinfo[i]; + writeln; + writeln('This Alpha version is licensed to:'); + write(stripcolor(s)); + writeln; + writeln('WARNING: Giving out this EXE file, or your BBS.EXE or BBS.OVR'); + writeln('files automatically terminates your status as an Alpha site.'); + end else begin + assign(siteinfof,siteinfofile); + reset(siteinfof); + repeat + readln(siteinfof,s); + siteinfos:=siteinfos+s+^J; + until ((eof(siteinfof)) or (length(siteinfos)>118)); + close(siteinfof); + end; + if (length(siteinfos)>118) then siteinfos:=copy(siteinfos,1,118); + r[24]:=length(siteinfos); + for i:=1 to 118 do r[i+24]:=random(256); + for i:=1 to length(siteinfos) do r[i+24]:=ord(siteinfos[i]); + + for i:=1 to 6 do r[i+6]:=random(256); { new encryption indices } + + chk:=0; + for i:=13 to 142 do inc(chk,r[i]); + chk1:=(chk div 6)*5; + chk2:=(chk div 19)*25; + r[143]:=chk1 mod 256; + r[144]:=chk2 mod 256; + + encryptinfo; + blockwrite(f,r,144,res); + if (res<>144) then writeln('Error writing data.'); + close(f); +end. diff --git a/mail0.pas b/mail0.pas new file mode 100644 index 0000000..0202b2f --- /dev/null +++ b/mail0.pas @@ -0,0 +1,403 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail0; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, timejunk; + +const + _brd_opened:boolean=FALSE; { has brdf been opened yet? } + oldnummsgs:integer=0; { old number of messages } + gotlastmheader:boolean=FALSE; + +type + pinforec=record + xbrdfnopen:string[160]; + xbread,xmintabloaded:longint; + xopen:boolean; + end; + +var + brdfnopen:string; { what *.BRD filename is open } + lastmheader:mheaderrec; + wasyourmsg:boolean; + +procedure blockwritestr2(var f:file; s:string); +procedure blockreadstr2(var f:file; var s:string); +function getmixnum(x:word):word; +function getmintab(x:word):word; +procedure loadmintab(x:word); +procedure ensureloaded(x:word); +procedure loadmhead1(var brdf:file; x:word; var mhead:mheaderrec); +procedure savemhead1(var brdf:file; mhead:mheaderrec); +procedure loadmhead(x:word; var mhead:mheaderrec); +procedure savemhead(mhead:mheaderrec); +procedure savemix(mixr:msgindexrec; x:word); +procedure newmix(mixr:msgindexrec); +procedure outmessagetext(fn:string; var mhead:mheaderrec; eraseit:boolean); +procedure findhimsg; +procedure initbrd(x:integer); +procedure closebrd; +function forwardm(n:integer):integer; +function moremail(u:userrec; un,what:word):boolean; +procedure savepinfo(var x:pinforec); +procedure loadpinfo(x:pinforec); +procedure delmail(x:integer); +function rmail(x:integer):string; { bread must = -1 } + +implementation + +procedure blockwritestr2(var f:file; s:string); +var bb:byte; +begin + bb:=$FF; + blockwrite(f,bb,1); + blockwrite(f,s[0],1); + blockwrite(f,s[1],ord(s[0])); +end; + +procedure blockreadstr2(var f:file; var s:string); +begin + blockread(f,s[0],1); { filler-chr } + if (ord(s[0])<>$FF) then exit; + blockread(f,s[0],1); + blockread(f,s[1],ord(s[0])); +end; + +function getmixnum(x:word):word; +begin + getmixnum:=x mod 100; +end; + +function getmintab(x:word):word; +begin + getmintab:=x div 100; +end; + +procedure loadmintab(x:word); +var lng:longint; + numread:word; + i,j:integer; +begin + lng:=x*100; (* stupid *#@$(@($#*($ TP typecasting... *) + while ((lng>=filesize(mixf)) and (x>0)) do begin + dec(x); + lng:=x*100; + end; + + mintaboffset:=x*100; + seek(mixf,mintaboffset); + blockread(mixf,mintab,100,numread); + if (numread<>100) then begin + for i:=numread to 99 do begin + mintab[i].messagenum:=0; + mintab[i].hdrptr:=-1; + mintab[i].msgid:=memboard.lastmsgid; + mintab[i].isreplytoid:=0; + for j:=1 to 6 do mintab[i].msgdate[i]:=0; + mintab[i].msgdowk:=0; + mintab[i].msgindexstat:=[]; + mintab[i].isreplyto:=65535; + mintab[i].numreplys:=0; + end; + seek(mixf,mintaboffset); + blockwrite(mixf,mintab,100); { fill remainder with garbage .. } + end; + mintabloaded:=x; +end; + +procedure ensureloaded(x:word); +var i:word; +begin + i:=getmintab(x); + if (i<>mintabloaded) then loadmintab(i); +end; + +procedure loadmhead1(var brdf:file; x:word; var mhead:mheaderrec); +begin + blockread(brdf,mhead,sizeof(mheaderrec)); +end; + +{ caller must postition to correct place in brdf .... } +procedure savemhead1(var brdf:file; mhead:mheaderrec); +begin + blockwrite(brdf,mhead,sizeof(mheaderrec)); +end; + +procedure loadmhead(x:word; var mhead:mheaderrec); +begin + ensureloaded(x); + seek(brdf,mintab[getmixnum(x)].hdrptr); + loadmhead1(brdf,x,mhead); +end; + +procedure savemhead(mhead:mheaderrec); +begin + savemhead1(brdf,mhead); +end; + +procedure savemix(mixr:msgindexrec; x:word); +begin + loadmintab(getmintab(x)); + seek(mixf,mintaboffset+getmixnum(x)); + blockwrite(mixf,mixr,1); + loadmintab(getmintab(x)); +end; + +procedure newmix(mixr:msgindexrec); +var lng:longint; + i,j:integer; +begin + if ((getmixnum(himsg+1)=0) and (himsg>-1)) then begin + for i:=0 to 99 do begin + mintab[i].messagenum:=0; + mintab[i].hdrptr:=-1; + mintab[i].msgid:=memboard.lastmsgid; + mintab[i].isreplytoid:=0; + for j:=1 to 6 do mintab[i].msgdate[i]:=0; + mintab[i].msgdowk:=0; + mintab[i].msgindexstat:=[]; + mintab[i].isreplyto:=65535; + mintab[i].numreplys:=0; + end; + inc(himintab); + seek(mixf,himintab*100); blockwrite(mixf,mintab[0],100); + end; + inc(himsg); savemix(mixr,himsg); +end; + +procedure outmessagetext(fn:string; var mhead:mheaderrec; eraseit:boolean); +var t:text; + f:file; + s:string; + lng:longint; +begin + assign(t,fn); + {$I-} reset(t); {$I+} + if (ioresult<>0) then exit; + lng:=filesize(brdf); + seek(brdf,lng); + mhead.msgptr:=lng+sizeof(mheaderrec); + savemhead(mhead); + + while (not eof(t)) do begin + readln(t,s); + blockwritestr2(brdf,s); + end; + close(t); + if (eraseit) then erase(t); +end; + +procedure findhimsg; +var mixr:msgindexrec; + lng:longint; + numread:word; +begin + himintab:=(filesize(mixf)-1) div 100; + himsg:=himintab*100-1; + seek(mixf,himsg+1); + repeat + lng:=himsg; + blockread(mixf,mixr,1,numread); + if ((numread=1) and (mixr.hdrptr<>-1)) then inc(himsg); + until (lng=himsg); +end; + +procedure initbrd(x:integer); { x=-1 = e-mail } +var mixr:msgindexrec; + fn:string; + lng:longint; + numread:word; + i,j:integer; +begin + closebrd; + + bread:=x; + if (x=-1) then fn:='EMAIL' else begin + loadboard(x); + fn:=memboard.filename; + end; + fn:=allcaps(fn); + brdfnopen:=fn; + assign(mixf,systat.msgpath+fn+'.MIX'); + {$I-} reset(mixf,sizeof(mixr)); {$I+} + if (ioresult<>0) then begin + rewrite(mixf,sizeof(mixr)); + for i:=0 to 99 do begin + mintab[i].messagenum:=0; + mintab[i].hdrptr:=-1; + mintab[i].msgid:=memboard.lastmsgid; + mintab[i].isreplytoid:=0; + for j:=1 to 6 do mintab[i].msgdate[i]:=0; + mintab[i].msgdowk:=0; + mintab[i].msgindexstat:=[]; + mintab[i].isreplyto:=65535; + mintab[i].numreplys:=0; + end; + blockwrite(mixf,mintab[0],100); + end; + + assign(brdf,systat.msgpath+fn+'.BRD'); + {$I-} reset(brdf,1); {$I+} + if (ioresult<>0) then rewrite(brdf,1); + + findhimsg; + loadmintab(himintab); + + _brd_opened:=TRUE; + gotlastmheader:=FALSE; + +end; + +procedure closebrd; +begin + if (_brd_opened) then begin + if (filerec(brdf).mode<>fmclosed) then close(brdf); + if (filerec(mixf).mode<>fmclosed) then close(mixf); + end; + filerec(brdf).mode:=fmclosed; + filerec(mixf).mode:=fmclosed; +end; + +{ this routine will find the user that user n is forwarding their mail to. + it will also check to get around "circular forwarding", such as: + 5 -> 10 -> 15 -> 5 ... } +function forwardm(n:integer):integer; +var chk:array[1..1250] of byte; { 1250 * 8 = 10000 users max } + cur:integer; + u:userrec; + done:boolean; + + function chkval(i:integer):boolean; + begin + dec(i); + chkval:=((chk[i div 8] and (1 shl (i mod 8)))<>0); + end; + + procedure chkset(i:integer); + var bb,bc:byte; + begin + dec(i); + bb:=chk[i div 8]; bc:=(1 shl(i mod 8)); + if ((bb and bc)=0) then chk[i div 8]:=chk[i div 8]+bc; + end; + +begin + for cur:=1 to 1250 do + chk[cur]:=0; + cur:=n; + done:=FALSE; + while not done do + if (chkval(cur)) then begin + done:=TRUE; + cur:=0; + end else + if (cur0) then begin + seek(uf,cur); read(uf,u); + if (u.deleted) then begin + done:=TRUE; + cur:=0; + end else begin + if (u.forusr=0) then begin + done:=TRUE; + end else begin + chkset(cur); + cur:=u.forusr; + end; + end; + end else begin + done:=TRUE; + cur:=0; + end; + forwardm:=cur; +end; + +{ + 1: user has too much mail waiting already + 2: user mailbox is closed + 3: user is deleted + 4: can't send mail to yourself! +} +function moremail(u:userrec; un,what:word):boolean; +begin + moremail:=TRUE; + case what of + 1:moremail:=(not (((aacs1(u,un,systat.csop)) and + (u.waiting>=systat.csmaxwaiting)) or + ((not aacs1(u,un,systat.csop)) and (u.waiting>=systat.maxwaiting)))); + 2:moremail:=(not (nomail in u.ac)); + 3:moremail:=(not (u.deleted)); + 4:moremail:=(not ((un=usernum) and (not cso))); + end; +end; + +procedure savepinfo(var x:pinforec); +begin + with x do begin + xbread:=bread; + xbrdfnopen:=brdfnopen; + xopen:=FALSE; + if (not _brd_opened) then xopen:=FALSE + else if (filerec(mixf).mode<>fmclosed) then xopen:=TRUE; + end; +end; + +procedure loadpinfo(x:pinforec); +begin + closebrd; + with x do begin + brdfnopen:=xbrdfnopen; + if (xopen) then begin + initbrd(xbread); + loadmintab(0); + end; + end; +end; + +{ toggles "existance" flag. If normal, deletes it -- otherwise, undeletes } +procedure delmail(x:integer); +var mixr:msgindexrec; +begin + ensureloaded(x); + mixr:=mintab[getmixnum(x)]; + if (miexist in mixr.msgindexstat) then + mixr.msgindexstat:=mixr.msgindexstat-[miexist] + else + mixr.msgindexstat:=mixr.msgindexstat+[miexist]; + savemix(mixr,x); + ensureloaded(x); +end; + +function rmail(x:integer):string; { bread must = -1 } +var u:userrec; + mheader:mheaderrec; + i:integer; + ufo:boolean; +begin + loadmhead(x,mheader); + with mheader do begin + rmail:=caps(fromi.alias)+' #'+cstr(fromi.usernum); + ufo:=(filerec(uf).mode<>fmclosed); + if (not ufo) then reset(uf); + if ((toi.usernum>=1) and (toi.usernum<=filesize(uf)-1)) then begin + if (toi.usernum=usernum) then dec(thisuser.waiting); + seek(uf,toi.usernum); + read(uf,u); + dec(u.waiting); + seek(uf,toi.usernum); + write(uf,u); + end; + if (not ufo) then close(uf); + end; + + delmail(x); + mailread:=TRUE; +end; + +end. diff --git a/mail1.pas b/mail1.pas new file mode 100644 index 0000000..ebf0179 --- /dev/null +++ b/mail1.pas @@ -0,0 +1,974 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail1; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common,timejunk; + +function inmsg(pub,uti:boolean; ftit:string; var mixr:msgindexrec; + var mheader:mheaderrec):boolean; +procedure inli(var i:string); + +implementation + +uses mail0; + +var + inmsgfile:text; + cmdsoff:boolean; + lastline:string; + +function inmsg(pub,uti:boolean; ftit:string; var mixr:msgindexrec; + var mheader:mheaderrec):boolean; +var li:array[1..160] of astr; + upin:string[255]; + an:anontyp; + mftit,fto,spc,s,s1,s2:string; + t,maxli,lc,ii,i,j,k,quoteli:integer; + c,c1:char; + cantabort,saveline,goquote,exited,save,abortit,abort,next,ptl1,ufo:boolean; + + procedure listit(stline:integer; linenum,disptotal:boolean); + var lasts:string; + l:integer; + begin + if (disptotal) then nl; + l:=stline; + abort:=FALSE; + next:=FALSE; + dosansion:=FALSE; + lasts:=''; + + while ((l0) then begin + insert(_new,v,p+length(old)); + delete(v,p,length(old)); + end; + end; + + procedure ptl; + var u:userrec; + sr:smalrec; + s,s1:astr; + i,j,tl:integer; + aa,aa1,done,ufo,sfo:boolean; + begin + tl:=60; + s1:=''; + nl; + if ((not ptl1) or (ftit<>'')) then begin + if (ftit<>'') then begin + prt('Subject: '); + print(mftit); + end else begin + prt('Old: '); + print(mftit); + end; + end else if ((pub) and (uti)) then begin + if (allcaps(copy(lastmheader.title,1,3))<>'RE:') then + s1:='Re: '+copy(lastmheader.title,1,64) else + s1:=lastmheader.title; + sprint(#3#5+'Hit Enter to use the default title of:'); + nl; + prt('Reply: '); + print(s1); + end; + if (ftit='') then begin + prt('Subject: '); + mpl(tl); + inputmain(s,tl,'l'); + if (s<>'') then begin + cl(1); + nl; + mftit:=s + end else begin + if (s1<>'') then begin + mftit:=s1; + cl(6); + prompt(mftit); + cl(1); + nl; + end; + if (ptl1) then exit else begin + cl(6); + prompt(mftit); + cl(1); + nl; + end; + end; + end; + if ((pub) and (ptl1) and (fto<>'')) then begin + nl; + prt('To: '); + cl(6); + s:=fto; + if (mbrealname in memboard.mbstat) then begin + if (mheader.toi.real<>'') then begin + s:=caps(mheader.toi.real); + if (memboard.mbtype=0) then s:=s+' #'+cstr(mheader.toi.usernum); + end else + s:=''; + end; + prompt(s); + for i:=1 to 50-length(s) do + prompt(' '); + nl; + ptl1:=FALSE; + exit; + end; + if ((pub) and (not uti)) then begin + nl; + sprint(#3#5+'Address message to what person/people?'); + sprompt(#3#5+'Press to leave '); + if (fto='') then sprint('unaddressed.') else sprint('unchanged.'); + nl; + if (not ptl1) then begin + prt('Old: '); + print(fto); + end; + prt('Reciever: '); + mpl(50); + inputmain(s,50,'lp'); + cl(6); + for i:=1 to length(s) do + prompt(^H' '^H); + aa1:=FALSE; + if (s<>'') then begin + fto:=s; + if (copy(s,1,1)='#') then s:=copy(s,2,length(s)-1); + val(s,i,j); + if ((i<>0) and (j=0)) then begin + ufo:=(filerec(uf).mode<>fmclosed); + if (not ufo) then reset(uf); + if ((i>=1) and (i<=filesize(uf)-1)) then begin + seek(uf,i); + read(uf,u); + fto:=caps(u.name)+' #'+cstr(i); + if (pub) then begin + if (mbrealname in memboard.mbstat) then fto:=caps(u.realname) + else fto:=caps(u.name); + if (memboard.mbtype=0) then fto:=fto+' #'+cstr(i); + end; + end else begin + prompt(s); + cl(1); + nl; + print('Unable to find user number (left unaddressed).'); + fto:=''; + aa1:=TRUE; + end; + if (not ufo) then close(uf); + end; + end; + aa:=(sqoutsp(fto)=''); + if (allcaps(sqoutsp(fto))='Everyone') then aa:=TRUE; + if (aa) then fto:='All'; + + if (not aa1) then begin + prompt(fto); + cl(1); + nl; + end; + + if (pap<>0) then nl; + nl; + if (not ptl1) then sprint(#3#0+'Please continue message...'); + end; + ptl1:=FALSE; + end; + + procedure rpl1; + begin + if (lc<=1) then sprint(#3#7+'Nothing to replace!') else begin + sprint(#3#5+'Replace string -'); + nl; + prt('On which line (1-'+cstr(lc-1)+') ? '); + input(s,4); + if (value(s)<1) or (value(s)>lc-1) then + sprint(#3#7+'Invalid line number.') + else begin + nl; + sprint(#3#3+'Original line:'); + abort:=FALSE; + next:=FALSE; + printacr(li[value(s)],abort,next); + nl; + sprint(#3#4+'Enter character(s) to replace:'); + prt(':'); + inputl(s1,78); + if (s1<>'') then + if (pos(s1,li[value(s)])=0) then + sprint(#3#7+'Character(s) not found.') + else begin + sprint(#3#4+'Enter replacement character(s):'); + prt(':'); + inputl(s2,78); + if (s2<>'') then begin + rpl(li[value(s)],s1,s2); + nl; + sprint(#3#3+'Edited line:'); + abort:=FALSE; + next:=FALSE; + printacr(li[value(s)],abort,next); + end; + end; + end; + nl; + end; + end; + + procedure doquote; + var f:text; + t1:integer; + s:string[80]; + done:boolean; + + procedure openquotefile; + begin + done:=FALSE; + assign(f,'msgtmp'); + {$I-} reset(f); {$I+} + if (ioresult<>0) then done:=TRUE; + end; + + procedure readquoteline; + begin + if eof(f) then done:=TRUE else begin + {$I-} readln(f,s); {$I+} + if (ioresult<>0) then done:=TRUE; + end; + end; + + procedure gotoquoteline(b:boolean); + begin + if (b) then begin + close(f); + openquotefile; + end; + if (not done) then begin + t1:=0; + repeat + inc(t1); + readquoteline; + until ((t1=quoteli) or (done)); + end; + if (done) then quoteli:=1; + end; + + procedure beginquote; + begin + if (lc>maxli) then done:=TRUE else begin + li[lc]:=('----------Begin Quote----------'); + inc(lc); + end; + end; + + procedure endquote; + begin + if (lc>maxli) then done:=TRUE else begin + li[lc]:=('-----------End Quote-----------'); + inc(lc); + end; + end; + + begin + beginquote; + openquotefile; + if (not done) then begin + done:=FALSE; + gotoquoteline(FALSE); + if (not done) then repeat + if (memboard.mbtype=0) then sprompt(#3+cstr(fidor.quote_color)) + else sprompt(#3+cstr(memboard.quote_color)); + sprint(s); + sprompt('[A]dd line [S]kip Line [P]revious Line [Q]uit :'); + repeat + getkey(c1); + c1:=upcase(c1); + until (c1 in ['A','S','Q','P','?',^M]); + for t1:=1 to 60 do + prompt(^H' '^H); + sprompt(#3#3); + case c1 of + 'A':begin + if (lc>maxli) then done:=TRUE else begin + li[lc]:=s; + inc(quoteli); + inc(lc); + readquoteline; + if (done) then dec(quoteli); + end; + end; + ^M,'S':begin + inc(quoteli); + readquoteline; + if (done) then dec(quoteli); + end; + 'P':if (quoteli>1) then begin + dec(quoteli); + gotoquoteline(TRUE); + end; + 'Q':done:=TRUE; + end; + until (done); + endquote; + end; + {$I-} close(f); {$I+} + end; + + procedure printmsgtitle; + begin + nl; + sprint(fstring.entermsg1); + sprint(fstring.entermsg2); + cl(3); + if (okansi) then + print(copy('/-------------------------------------\_/-------------------------------------\', + 1,thisuser.linelen)) else + print(copy('/-------------------------------------\_/-------------------------------------\', + 1,thisuser.linelen)); + end; + + procedure inputthemessage; + var t1:integer; + begin + cmdsoff:=FALSE; + abort:=FALSE; + next:=FALSE; + ptl1:=TRUE; + goquote:=FALSE; + quoteli:=1; + if (freek(exdrv(systat.msgpath))>>>'+#3#3+' Main BBS drive full! Insufficient space to save a message!') + else sysoplog(#3#8+'>>>>'+#3#3+' '+c+': drive full! Insufficient space to save a message!'); + end else begin + lc:=1; + spc:=' '; + lastline:=''; + if cso then maxli:=systat.csmaxlines + else maxli:=systat.maxlines; + ptl; + end; + if (mftit='') then + if (not cantabort) then begin + save:=FALSE; + exit; + end; + printmsgtitle; + repeat + repeat + saveline:=TRUE; + nofeed:=FALSE; + exited:=FALSE; + save:=FALSE; + abortit:=FALSE; + write_msg:=TRUE; + inli(s); + write_msg:=FALSE; + if (s='/'^H) then begin + saveline:=FALSE; + if (lc<>1) then begin + dec(lc); + lastline:=li[lc]; + if (copy(lastline,length(lastline),1)=#1) then + lastline:=copy(lastline,1,length(lastline)-1); + sprint(#3#0+'Backed up to line '+cstr(lc)+':'); + end; + end; + if (s='/') then begin + sprompt('^3Command (^0?^3=^0help^3) : ^3'); + getkey(c); + for t1:=1 to 19 do + prompt(^H' '^H); + saveline:=FALSE; + case upcase(c) of + '/','\':begin + if (mso) then sprompt(#3#0+'[C]enter [T]itle [U]pload : ') + else sprompt(#3#0+'[C]enter [T]itle : '); + getkey(c1); c1:=upcase(c1); + if (mso) then for t1:=1 to 28 do prompt(^H' '^H) + else for t1:=1 to 19 do prompt(^H' '^H); + if (c1 in ['C','T']) then begin + sprint(#3#3+c1+#3#1+':'+#3#3); + inli(s); + if (s<>'') then begin + case c1 of + 'C':s:=#2+s; + 'T':s:=BOXEDTITLE+s; + end; + saveline:=TRUE; + end; + end; + if ((not hangup) and (c1='U') and (mso)) then begin + prt('Enter file name to upload: '); + mpl(40); + inputl(s,40); + if ((s<>'') and (not hangup)) then begin + assign(inmsgfile,s); + {$I-} reset(inmsgfile); {$I+} + if (ioresult<>0) then + print('File not found.') + else begin + inmsgfileopen:=TRUE; + cmdsoff:=TRUE; + end; + end; + end; + end; + '?','H':printf('prhelp'); + 'A':if (not cantabort) then + if pynq('@M^7Abort message? ') then begin + exited:=TRUE; + abortit:=TRUE; + end else + sprint(#3#0+'Nothing done.@M'); + 'C':if pynq('@M^7Clear message? ') then begin + sprint(#3#0+'Message cleared.... Start over...'); + lc:=1; + end else + sprint(#3#0+'Nothing done.@M'); + 'E':exited:=TRUE; + 'L':listit(1,pynq('@M^7List message with line numbers? '),TRUE); + 'O':printf('color'); + 'P':rpl1; + 'Q':if (not exist('msgtmp')) then + sprint(#3#0+'You are not replying to a message.@M') + else + goquote:=TRUE; + 'R':if (lc>1) then begin + sprint(#3#0+'Last line deleted. Continue:'+#3#1); + dec(lc); + end; + 'S':if ((not cantabort) or (lc>1)) then begin + exited:=TRUE; + save:=TRUE; + end; + 'T':ptl; + end; + end; + + if (goquote) then begin + doquote; + goquote:=FALSE; + cls; + sprint(#3#0+'Quoting complete. Continue:'); + printmsgtitle; + if (lc>1) then + if (lc>10) then listit(lc-10,FALSE,FALSE) + else listit(1,FALSE,FALSE); + end; + + if (saveline) then begin + li[lc]:=s; + inc(lc); + if (lc>maxli) then begin + print('You have used up your maximum amount of lines.'); + if (inmsgfileopen) then begin + inmsgfileopen:=FALSE; + cmdsoff:=FALSE; + close(inmsgfile); + end; + exited:=TRUE; + end; + end; + until ((exited) or (hangup)); + if (hangup) then abortit:=TRUE; + if ((not abortit) and (not save)) then + repeat + prt(#3#3+'Message editor (^0?^3=^0help^3) : '); + onek(c,'SACDILRTU?'); nl; + case c of + '?':begin + lcmds(15,3,'List message','Continue message'); + lcmds(15,3,'Save message','Abort message'); + lcmds(15,3,'Delete line','Insert line'); + lcmds(15,3,'Replace line','Update line'); + lcmds(15,3,'Title re-do',''); + end; + 'A':if (not cantabort) then + if pynq('Abort message? ') then abortit:=TRUE + else c:=' '; + 'C':if (lc>maxli) then begin + sprint(#3#7+'Too many lines!'); + c:=' '; + end else + sprompt(#3#0+'Continue...'); + 'D':begin + prt('Delete which line (1-'+cstr(lc-1)+') ? '); + input(s,4); + t:=value(s); + if (t>0) and (t0) and (t0) and (t#1) then li[t]:=s+#1 else li[t]:=s; + end; + end; + 'S':if ((not cantabort) or (lc>1)) then + save:=TRUE; + 'T':ptl; + 'U':rpl1; + end; + nl; + until (c in ['A','C','S']) or (hangup); + until ((abortit) or (save) or (hangup)); + if (lc=1) then begin + abortit:=TRUE; + save:=FALSE; + end; + end; + + function getorigin:string; + var s:astr; + begin + if (memboard.origin<>'') then s:=memboard.origin + else if (fidor.origin<>'') then s:=fidor.origin + else s:=copy(stripcolor(systat.bbsname),1,50); + while (copy(s,length(s),1)=' ') do + s:=copy(s,1,length(s)-1); + getorigin:=s; + end; + + procedure saveit; + var t:text; + i,j,qcolor,tcolor:integer; + c:char; + s:astr; + + function getaddr(zone,net,node,point:integer):string; + begin + getaddr:=cstr(zone)+':'+cstr(net)+'/'+cstr(node)+'.'+cstr(point)+')'; + end; + + begin + mheader.msglength:=0; + with memboard do begin + if (mbtype in [1,2]) then begin + qcolor:=quote_color; + tcolor:=text_color; + end else begin + qcolor:=fidor.quote_color; + tcolor:=fidor.text_color; + end; + assign(t,'tgtemp1.$$$'); rewrite(t); + if ((pub) and (mbfilter in mbstat)) then begin + for i:=1 to lc-1 do + if length(li[i])>0 then begin + li[i]:=stripcolor(li[i]); + for j:=1 to length(li[i]) do begin + c:=li[i][j]; + if (c in [#0..#1,#3..#31,#127..#255]) then c:='*'; + li[i][j]:=c; + end; + end; + end; + for i:=1 to lc-1 do begin + s:=li[i]; + j:=pos('>',stripcolor(s)); + if ((not pub) or (mbtype=0) or (copy(s,1,3)='`#[') or (s[1]=#2)) + then j:=0; + if ((j>0) and (j<=5)) then s:=#3+cstr(qcolor)+s+#3+cstr(tcolor); + writeln(t,s); + inc(mheader.msglength,length(s)+2); + end; + if ((pub) and (mbtype in [1,2]) and (mbaddtear in mbstat)) then begin + writeln(t,''); + inc(mheader.msglength,2); + s:=#3+cstr(tear_color)+'--- Telegard v'+ver; + writeln(t,s); + inc(mheader.msglength,length(s)+2); + s:=#3+cstr(origin_color)+' * Origin: '+getorigin+' ('; + if (zone<>0) then s:=s+getaddr(zone,net,node,point) + else s:=s+getaddr(fidor.zone,fidor.net,fidor.node,fidor.point); + writeln(t,s); + inc(mheader.msglength,length(s)+2); + end; + close(t); + outmessagetext('tgtemp1.$$$',mheader,TRUE); + end; + end; + + procedure readytogo; + var f:file; + begin + if (exist('msgtmp')) then begin + assign(f,'msgtmp'); + {$I-} reset(f); {$I+} + if (ioresult=0) then begin + close(f); + erase(f); + end; + end; + end; + +begin + inmsg:=FALSE; + if (uti) then fto:=caps(mheader.toi.as) + else fto:=''; + if (ftit<>'') then mftit:=ftit + else mftit:=''; + if (copy(mftit,1,1)='\') then begin + mftit:=copy(mftit,2,length(mftit)-1); + cantabort:=TRUE; + end else + cantabort:=FALSE; + inputthemessage; + if (not save) then begin + print('Aborted.'); + readytogo; + exit; + end; + + with mheader do begin + signature:=$FFFFFFFF; + title:=mftit; + origindate:=''; + with fromi do begin + anon:=0; + usernum:=common.usernum; + as:=allcaps(thisuser.name); + if ((not pub) or (memboard.mbtype=0)) then + as:=as+' #'+cstr(common.usernum); + real:=allcaps(thisuser.realname); + alias:=allcaps(thisuser.name); + end; + if (not uti) then + with toi do begin + anon:=0; + usernum:=0; + as:=''; + if (allcaps(sqoutsp(fto))='EVERYONE') then fto:=''; + if (pub) then as:=fto; + real:=''; + alias:=''; + end; + end; + + loadboard(board); + if (pub) then begin + an:=memboard.anonymous; + if ((an=atno) and (aacs(systat.anonpubpost))) then an:=atyes; + if (rpostan in thisuser.ac) then an:=atno; + end else + if (aacs(systat.anonprivpost)) then an:=atyes else an:=atno; + case an of + atno :; + atforced :if (cso) then mheader.fromi.anon:=2 + else mheader.fromi.anon:=1; + atyes :begin + nl; + if pynq(aonoff(pub,'Post Anonymously? ', + 'Send Anonymously? ')) then + if (cso) then mheader.fromi.anon:=2 + else mheader.fromi.anon:=1; + end; + atdearabby:begin + nl; + sprint(aonoff(pub,'Post as:','Send as:')); + nl; + sprint(#3#3+'1. ^7[^0User ^8X^7]'); + sprint(#3#3+'2. ^1Problemed Person'); + sprint(#3#3+'3. ^1'+nam); + nl; + prt('Which? '); onek(c,'123N'^M); + case c of + '1':mheader.fromi.anon:=3; + '2':mheader.fromi.anon:=4; + end; + end; + atanyname :begin + nl; + sprint('You can post your message under any name'); + sprint('you want on this base.'); + nl; + print('Enter name, or for your own.'); + prt('Name: '); input(s,36); + if (s<>'') then begin + mheader.fromi.anon:=5; + mheader.fromi.as:=caps(s); + end; + end; + end; + if ((pub) and (himsg<>65535)) then begin + j:=0; + for i:=0 to himsg do begin + ensureloaded(i); + k:=mintab[getmixnum(i)].messagenum; + if (k>j) then j:=k; + end; + mixr.messagenum:=j+1; + end; + with mixr do begin + hdrptr:=filesize(brdf); + isreplytoid:=0; + isreplyto:=65535; + numreplys:=0; + getpackdatetime(@msgdate); + getdayofweek(msgdowk); + msgid:=memboard.lastmsgid; + inc(memboard.lastmsgid); + msgindexstat:=[miexist]; + if (pub) then begin + if (rvalidate in thisuser.ac) then + msgindexstat:=msgindexstat+[miunvalidated]; + if (aacs(memboard.mciacs)) then + msgindexstat:=msgindexstat+[miallowmci]; + end; + end; + + nl; + sprompt(#3#7+'I am processing your message...'); + while ((lc>1) and ((li[lc-1]='') or (li[lc-1]=^J))) do + dec(lc); + + saveit; + savesystat; + ufo:=(filerec(bf).mode<>fmclosed); + if (not ufo) then reset(bf); + seek(bf,board-1); + write(bf,memboard); + if (not ufo) then close(bf); + + cl(5); + for t:=1 to 31 do begin + prompt('<'); + delay(20); + prompt(^H' '^H^H); + end; + prompt('*'); + delay(20); + prompt(^H' '^H); + cl(9); + readytogo; + inmsg:=TRUE; +end; + +procedure inli(var i:string); +var s:astr; + cp,rp,cv,cc,xxy:integer; + c,c1,ccc,d:char; + hitcmdkey,hitbkspc,escp,dothischar,abort,next,savallowabort:boolean; + + procedure bkspc; + begin + if (cp>1) then begin + if (i[cp-2]=#3) and (i[cp-1] in [#0..#9]) then begin + dec(cp); + cl(1); + end else + if (i[cp-1]=^H) then begin + prompt(' '); + inc(rp); + end else + if (i[cp-1]<>#10) then begin + prompt(^H' '^H); + dec(rp); + end; + dec(cp); + end; + end; + +begin + write_msg:=TRUE; hitcmdkey:=FALSE; hitbkspc:=FALSE; + ccc:='1'; + escp:=FALSE; + rp:=1; cp:=1; + i:=''; + if (lastline<>'') then begin + abort:=FALSE; next:=FALSE; + savallowabort:=allowabort; allowabort:=FALSE; + reading_a_msg:=TRUE; + printa1(lastline,abort,next); + reading_a_msg:=FALSE; + allowabort:=savallowabort; + i:=lastline; lastline:=''; + escp:=(pos(^[,i)<>0); + cp:=length(i)+1; + rp:=cp; + end; + repeat + if ((inmsgfileopen) and (buf='')) then + if (not eof(inmsgfile)) then begin + readln(inmsgfile,buf); + buf:=buf+^M; + end else begin + close(inmsgfile); + inmsgfileopen:=FALSE; cmdsoff:=FALSE; + dosansion:=FALSE; + buf:=^P+'1'; + end; + getkey(c); + + dothischar:=FALSE; + if (c=^G) then begin + cmdsoff:=not cmdsoff; + nl; nl; + if (cmdsoff) then begin + sprint(#3#5+'Message commands OFF now, to allow entry of special characters.'); + sprint(#3#5+'Press Ctrl-G again to turn message commands back on.'); + end else + sprint(#3#5+'Message commands back on again.'); + nl; + for xxy:=1 to cp do s[xxy]:=i[xxy]; s[0]:=chr(cp-1); + abort:=FALSE; next:=FALSE; + reading_a_msg:=TRUE; printa1(s,abort,next); reading_a_msg:=FALSE; + end; + if (not cmdsoff) then + if ((c>=#32) and (c<=#255)) then begin + if (c='/') and (cp=1) then hitcmdkey:=TRUE else dothischar:=TRUE; + end else + case c of + ^[:dothischar:=TRUE; + ^B:dm(' -'^N'/'^N'l'^N'\'^N,c); + ^H:if (cp=1) then begin + hitcmdkey:=TRUE; + hitbkspc:=TRUE; + end else + bkspc; + ^I:begin + cv:=5-(cp mod 5); + if (cp+cv#3)); + ^X:begin + cp:=1; + for cv:=1 to rp-1 do prompt(^H' '^H); + rp:=1; + if (ccc<>'1') then begin + c1:=ccc; i[cp]:=#3; + inc(cp); i[cp]:=chr(ord(c1)-ord('0')); + inc(cp); cl(ord(i[cp-1])); + end; + end; + end; + + if ((dothischar) or (cmdsoff)) and ((c<>^G) and (c<>^M)) then + if ((cp^M) and (cp<>strlen) and (not escp) then begin + cv:=cp-1; + while (cv>1) and (i[cv]<>' ') and ((i[cv]<>^H) or (i[cv-1]=#3)) do dec(cv); + if (cv>rp div 2) and (cv<>cp-1) then begin + lastline:=copy(i,cv+1,cp-cv); + for cc:=cp-2 downto cv do prompt(^H); + for cc:=cp-2 downto cv do prompt(' '); + i[0]:=chr(cv-1); + end; + end; + + if (escp) and (rp=thisuser.linelen) then cp:=strlen; + if (cp<>strlen) then nl + else begin + rp:=1; cp:=1; + i:=i+#29; + end; + end; + + write_msg:=FALSE; +end; + +end. diff --git a/mail2.pas b/mail2.pas new file mode 100644 index 0000000..18fb5f3 --- /dev/null +++ b/mail2.pas @@ -0,0 +1,390 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail2; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, timejunk, mail0, mail1; + +procedure ssmail(mstr:astr); +procedure smail(massmail:boolean); +procedure email1(x:integer; ftit:string); +procedure email(x:integer); +procedure imail(x:integer); +function maxage(x:integer):integer; + +implementation + +uses misc3, miscx; + +procedure ssmail(mstr:astr); +begin + if (mstr='') then smail(FALSE) + else begin + if (pos(';',mstr)=0) then irt:='Feedback' else + irt:=copy(mstr,pos(';',mstr)+1,length(mstr)); + imail(value(mstr)); + end; +end; + +procedure smail(massmail:boolean); +var u,u2:userrec; + mheader:mheaderrec; + mixr:msgindexrec; + na:array[1..20] of word; + massacs,s:string; + i,nac,x:integer; + stype:byte; + abort,next,ok:boolean; + + procedure checkitout(var x:integer; showit:boolean); + var i,ox:integer; + b:boolean; + + procedure unote(s:string); + begin + if (showit) then + print('[> '+caps(u.name)+' #'+cstr(x)+': '+s); + end; + + begin + {x:=value(s);} ox:=x; + if ((x<1) or (x>filesize(uf)-1)) then begin x:=0; exit; end; + seek(uf,x); read(uf,u); + + i:=0; b:=TRUE; + while ((i<4) and (b)) do begin + inc(i); b:=moremail(u,x,i); + if (not b) then + case i of + 1:unote('Mailbox is full.'); + 2:unote('Mailbox is closed.'); + 3:x:=0; + 4:unote('Can''t send mail to yourself!'); + end; + end; + + if (not b) then begin x:=0; exit; end; + i:=u.forusr; if ((i<1) or (i>filesize(uf)-1)) then i:=0; + if (i<>0) then begin + seek(uf,i); read(uf,u2); + unote('Mail forwarded to '+caps(u2.name)+' #'+cstr(i)+'.'); + x:=i; + end; + if (showit) then + for i:=1 to 20 do + if (na[i]=x) then begin + unote('Can''t send more than once.'); + x:=0; exit; + end; + if (ox<>x) then + if ((ox>=1) and (ox<=filesize(uf)-1)) then begin + seek(uf,ox); read(uf,u); + end; + end; + + procedure sendit(x:integer); + begin + checkitout(x,FALSE); + if (x=0) then exit; + + if ((x>=1) and (x<=filesize(uf)-1)) then begin + seek(uf,x); read(uf,u); + if (x=1) then begin + inc(thisuser.feedback); + inc(ftoday); + end else begin + inc(thisuser.emailsent); + inc(etoday); + end; + inc(u.waiting); + seek(uf,x); write(uf,u); + if (x=usernum) then inc(thisuser.waiting); + end; + + with mheader.toi do begin + anon:=0; + usernum:=x; + as:=allcaps(u.name)+' #'+cstr(x); + real:=allcaps(u.realname); + alias:=allcaps(u.name); + end; + with mixr do begin + messagenum:=x; + msgid:=0; + hdrptr:=filesize(brdf); + msgindexstat:=msgindexstat+[mimassmail]; + end; + + seek(brdf,mixr.hdrptr); + savemhead(mheader); + newmix(mixr); + end; + + procedure doit; + var s:string; + i,x:integer; + begin + initbrd(-1); + if (not inmsg(FALSE,FALSE,'',mixr,mheader)) then exit; + case stype of + 0:begin + nl; print('Sending mass-mail to:'); + sysoplog('Mass-mail sent to:'); + for i:=1 to nac do begin + sendit(na[i]); s:=' '+caps(u.name)+' #'+cstr(na[i]); + sysoplog(s); print(s); + end; + end; + 1:begin + nl; print('Sending mass-mail to:'); + sysoplog('Mass-mail sent to: (by ACS "'+massacs+'")'); + seek(uf,1); + for i:=1 to filesize(uf)-1 do begin + read(uf,u); + if (aacs1(u,i,massacs)) then begin + sendit(i); s:=' '+caps(u.name)+' #'+cstr(i); + sysoplog(s); print(s); + end; + end; + end; + 2:begin + print('Sending mass-mail to ALL USERS.'); + sysoplog('Mass-mail sent to ALL USERS.'); + for i:=1 to filesize(uf)-1 do sendit(i); + end; + end; + end; + +begin + nl; + if ((remail in thisuser.ac) or (not (aacs(systat.normprivpost)))) then begin + print('Your access privledges do not include sending mail.'); + exit; + end else + if ((etoday>=systat.maxprivpost) and (not mso)) then begin + print('Too much mail send today already.'); + exit; + end; + if (not massmail) then begin + print('Enter user number, user name, or partial search string:'); + prt(':'); finduserws(x); + if (x>0) then imail(x); + end else begin + print('Mass mail: send mail to more than one user.'); + print('Enter a max of 20 user NUMBERS, seperated by commas.'); + if (cso) then begin + print('CoSysOps:'); + print(' ALL: Send to every user.'); + print(' ACS: Send to an ACS group of users.'); + end; + prt(':'); input(s,78); if (s='') then exit; + reset(uf); + ok:=FALSE; nac:=0; stype:=0; + for i:=1 to 20 do na[i]:=0; + nl; + if (cso) then + if (s='ACS') then begin + ok:=TRUE; + stype:=1; + prt('Enter ACS: '); inputl(massacs,160); + if (massacs='') then begin close(uf); exit; end; + seek(uf,1); i:=1; + nl; + print('Users marked by ACS "'+massacs+'":'); + abort:=FALSE; next:=FALSE; + while ((i<=filesize(uf)-1) and (not abort)) do begin + read(uf,u); + if (aacs1(u,i,massacs)) then + print(' '+caps(u.name)+' #'+cstr(i)); + inc(i); wkey(abort,next); + end; + end else + if (s='ALL') then begin + ok:=FALSE; + print('ALL USERS marked for mass-mail.'); + stype:=2; + end; + if (not ok) then begin + print('Users marked:'); + while ((s<>'') and (nac<20)) do begin + x:=value(s); checkitout(x,TRUE); + if (x<>0) then begin + inc(nac); na[nac]:=x; + print(' '+caps(u.name)+' #'+cstr(x)); + end; + i:=pos(',',s); if (i=0) then s:=''; + if (s<>'') then s:=copy(s,i+1,length(s)-i); + end; + end; + nl; + if pynq('Is this OK? ') then begin doit; closebrd; end; + close(uf); + end; +end; + +procedure email1(x:integer; ftit:string); +var u:userrec; + pinfo:pinforec; + mheader:mheaderrec; + mixr:msgindexrec; + fto:string; + i,t,e,cp:integer; + a:anontyp; + s,tousers:astr; + us:userrec; + bb:byte; + b,ok,wasanon:boolean; + + procedure nope(s:astr); + begin + if ok then begin nl; print(s); end; + ok:=FALSE; + end; + +begin + ok:=TRUE; + reset(uf); + if ((x<0) or (x>filesize(uf)-1)) then begin close(uf); exit; end; + if (copy(ftit,1,1)<>'\') then begin + seek(uf,x); read(uf,u); close(uf); + nl; + if ((remail in thisuser.ac) or (not aacs(systat.normprivpost))) and + (not mso) then + nope('Your access privledges do not include sending mail.'); + if (etoday>=systat.maxprivpost) and (not mso) then + nope('Too much mail sent today.'); + if ((x=1) and (ftoday>=systat.maxfback) and (not mso)) then + nope('Too much feedback sent today.'); + + i:=0; b:=TRUE; + while ((i<4) and (b)) do begin + inc(i); b:=moremail(u,x,i); + if (not b) then + case i of + 1:nope('That user''s mailbox is full.'); + 2:nope('That user''s mailbox is closed.'); + 3:nope('That user has been deleted.'); + 4:nope('Why do you want to send mail to yourself!??!'); + end; + end; + + if ((cso) and (not b) and (i<>3)) then ok:=TRUE; + if (not ok) then exit; + end; + + savepinfo(pinfo); + initbrd(-1); + + if (inmsg(FALSE,FALSE,ftit,mixr,mheader)) then begin + reset(uf); + if ((x>=1) and (x<=filesize(uf)-1)) then begin + seek(uf,x); read(uf,u); + if (x=1) then begin + inc(thisuser.feedback); + inc(ftoday); + end else begin + inc(thisuser.emailsent); + inc(etoday); + end; + inc(u.waiting); + seek(uf,x); write(uf,u); + if (x=usernum) then inc(thisuser.waiting); + end; + close(uf); + + with mheader.toi do begin + anon:=0; + usernum:=x; + as:=allcaps(u.name)+' #'+cstr(x); + real:=allcaps(u.realname); + alias:=allcaps(u.name); + end; + mixr.msgid:=0; + mixr.messagenum:=x; + + seek(brdf,mixr.hdrptr); + savemhead(mheader); + newmix(mixr); + + s:=caps(u.name)+' #'+cstr(x); + if (useron) then sysoplog('Mail sent to '+s); + print('Mail sent to '+s); + topscr; + end; + + loadpinfo(pinfo); +end; + +procedure email(x:integer); + begin email1(x,''); end; + +procedure imail(x:integer); +var u:userrec; + i:integer; + b,xx:boolean; + + procedure nope(s:string); + begin + if (not xx) then begin + print(s); + xx:=TRUE; + end; + end; + +begin + xx:=FALSE; + reset(uf); + if ((x<1) or (x>filesize(uf)-1)) then begin close(uf); exit; end; + seek(uf,x); read(uf,u); + nl; + + i:=0; b:=TRUE; + while ((i<4) and (b)) do begin + inc(i); b:=moremail(u,x,i); + if (not b) then + case i of + 1:nope('That user''s mailbox is full.'); + 2:nope('That user''s mailbox is closed.'); + 3:nope('That user has been deleted.'); + 4:nope('Why do you want to send mail to yourself!??!'); + end; + end; + + if (xx) then begin close(uf); exit; end; + if (u.forusr<>0) then begin + x:=forwardm(x); + if ((x<1) or (x>filesize(uf)-1)) then x:=0; + if (x>0) then begin + seek(uf,x); read(uf,u); close(uf); + print('That user is forwarding his mail to '+caps(u.name)+'.'); + if pynq('Send mail to ['+caps(u.name)+' #'+cstr(x)+'] ? ') then email(x); + end else begin + print('Can''t send mail to that user.'); + close(uf); + end; + end else begin + close(uf); + if pynq('Send mail to ['+caps(u.name)+' #'+cstr(x)+']? ') then email(x); + end; +end; + +function maxage(x:integer):integer; +begin + case x of + 0..19:maxage:=5; + 20..29:maxage:=14; + 30..39:maxage:=90; + 40..59:maxage:=120; + else + maxage:=255; + end; +end; + +end. +end. diff --git a/mail3.pas b/mail3.pas new file mode 100644 index 0000000..901cd8f --- /dev/null +++ b/mail3.pas @@ -0,0 +1,244 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail3; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, timejunk, mail0; + +function what00(b:byte; s:string):string; +procedure readmsg(style:byte; anum,mnum,tnum:longint; var abort,next:boolean); + +implementation + +function what00(b:byte; s:string):string; +begin + if (b=0) then + s:=caps(s) + else + case b of + 0:s:=caps(s); + 1, + 2:s:='**Anonymous**'; + 3:s:='"Abby"'; + 4:s:='"Problemed Person"'; + 5:s:=caps(s); + else + s:=allcaps(s); + end; + what00:=s; +end; + +{ anum=actual, mnum=M#/t#, tnum=m#/T# } +procedure readmsg(style:byte; anum,mnum,tnum:longint; var abort,next:boolean); +var mhead:mheaderrec; + mixr:msgindexrec; + pdt:packdatetime; + dt:ldatetimerec; + s,s1:string; + brdsig,lng,maxm,totload:longint; + i,numread:word; + done,pub,seeanon,usemci,usereal,isfido:boolean; + + procedure getout; + begin + gotlastmheader:=TRUE; + lastmheader:=mhead; + end; + + function tnn(lng:longint):string; + var s:string; + begin + if (lng>100) then lng:=lng mod 100; { ex: 1989 --> 89 } + s:=cstr(lng); while (length(s)<2) do s:='0'+s; + tnn:=s; + end; + +begin + usereal:=(mbrealname in memboard.mbstat); + isfido:=(memboard.mbtype<>0); + + {rcg1117 removed mixr...} + {with mhead,mixr do begin} + + with mhead do begin + + loadmhead(anum,mhead); + ensureloaded(anum); + mixr:=mintab[getmixnum(anum)]; + usemci:=(miallowmci in mixr.msgindexstat); + + loadboard(board); + wasyourmsg:=(fromi.usernum=usernum); + pub:=(bread<>-1); + if (pub) then seeanon:=aacs(systat.anonpubread) + else seeanon:=aacs(systat.anonprivread); + + if (mhead.fromi.anon=2) then seeanon:=aacs(systat.csop); + + abort:=FALSE; + next:=FALSE; + printacr('',abort,next); + + s:='Number: '+#3#3+cstr(mnum)+'/'+cstr(tnum); + printacr(s,abort,next); + + s:=''; + if (not (miexist in mixr.msgindexstat)) then begin + s:='Status: '+#3#8+'Deleted'; + if ((not mso) and (not wasyourmsg)) then begin + printacr(s,abort,next); + getout; + exit; + end; + end; + + if (miunvalidated in mixr.msgindexstat) then begin + if (s='') then s:='Status:'; + s:=s+#3#7+' Not Validated'; + if ((not mso) and (not wasyourmsg)) then begin + printacr(s,abort,next); + getout; + exit; + end; + end; + + {rcg1117 added mixr...} + {if ((pub) and (mipermanent in msgindexstat)) then begin} + + if ((pub) and (mipermanent in mixr.msgindexstat)) then begin + if (s='') then s:='Status:'; + s:=s+#3#3+' Permanent'; + end; + + if (s<>'') then printacr(s,abort,next); + + {rcg1117 added mixr...} + {if ((fromi.anon=0) or (seeanon)) then s:=pdt2dat(@msgdate,msgdowk)} + + if ((fromi.anon=0) or (seeanon)) then s:=pdt2dat(@mixr.msgdate,mixr.msgdowk) + else s:='***Unknown***'; + s:='Date : '+#3#3+s; + + if (style=4) then begin + s:=s+#3#1+' ('+aonoff(pub,'Posted: ','Sent: ')+#3#9; + for i:=1 to 6 do + pdt[i]:=mixr.msgdate[i]; + pdt2dt(pdt,dt); + s1:=tnn(dt.month)+'/'+tnn(dt.day)+'/'+tnn(dt.year); + i:=daynum(date)-daynum(s1); + s:=s+cstr(i)+' day'+aonoff((i=1),'','s')+' ago'+#3#1+')'; + end; + + printacr(s,abort,next); + if (origindate<>'') then + if ((fromi.anon=0) or (seeanon)) then + printacr('Origin: '+#3#3+origindate,abort,next); + + s1:=fromi.as; + if (pub) then begin + if (usereal) then begin + s1:=fromi.real; + if (not isfido) then s1:=s1+' #'+cstr(fromi.usernum); + end; + end; + s:='From : '+#3#5+caps(what00(fromi.anon,s1)); + if (not abort) then sprint(s); + + if ((seeanon) and (fromi.anon<>0) and (toi.anon=0) and (not isfido)) then begin + s1:='(Real : '+#3#5; + if (usereal) then s1:=s1+caps(fromi.real) + else s1:=s1+caps(fromi.alias); + s1:=s1+' #'+cstr(fromi.usernum)+#3#1+')'; + printacr(s1,abort,next); + end; + + if (style<>2) then begin + s1:=toi.as; + if (pub) then begin + if ((toi.as='') and (isfido)) then s1:='All' else begin + if ((usereal) and (toi.real<>'')) then begin + s1:=allcaps(toi.real); + if (not isfido) then s1:=s1+' #'+cstr(toi.usernum); + end; + end; + end; + if (s1<>'') then begin + s:='To : '+#3#5+caps(what00(toi.anon,s1)); + if (not usemci) then printacr(s,abort,next) else begin + sprint(s); + wkey(abort,next); + end; + end; + if ((seeanon) and (toi.anon<>0) and (not isfido)) then begin + if (fromi.anon=0) then begin + s1:='(The user really is : '+#3#5; + if (usereal) then s1:=s1+caps(toi.real) + else s1:=s1+caps(toi.alias); + s1:=s1+' #'+cstr(toi.usernum)+#3#1+')'; + printacr(s1,abort,next); + end else begin + s1:='(The user really is : '+#3#5; + if (usereal) then s1:=s1+caps(fromi.real) + else s1:=s1+caps(fromi.alias); + s1:=s1+' --> '; + if (usereal) then s1:=s1+caps(toi.real) + else s1:=s1+caps(toi.alias); + s1:=s1+#3#1+')'; + printacr(s1,abort,next); + end; + end; + end; + + if (not usemci) then + printacr('Subject : '+#3#3+title,abort,next) + else begin + sprint('Subject : '+#3#3+title); + wkey(abort,next); + end; + + if (mixr.isreplyto<>65535) then + printacr(' >> '+#3#3+'Reply to message '+#3#5+cstr(mixr.isreplyto+1), + abort,next); + i:=mixr.numreplys; + if (i<>0) then + printacr(' >> '+#3#3+'This message has '+#3#5+cstr(i)+#3#3+' repl'+ + aonoff((i=1),'y','ies'),abort,next); + printacr('',abort,next); + + if ((fromi.anon=0) or (seeanon)) then + lastname:=caps(what00(fromi.anon,fromi.as)) + else + lastname:=''; + + if (not abort) then begin + reading_a_msg:=TRUE; + + {rcg1117 added mixr...} + {read_with_mci:=(miallowmci in msgindexstat);} + read_with_mci:=(miallowmci in mixr.msgindexstat); + + totload:=0; + abort:=FALSE; + next:=FALSE; + seek(brdf,mhead.msgptr); + repeat + blockreadstr2(brdf,s); + inc(totload,length(s)+2); + printacr(s,abort,next); + until ((totload>=msglength) or (abort)); + read_with_mci:=FALSE; + reading_a_msg:=FALSE; + printacr('',abort,next); + if (dosansion) then redrawforansi; + end; + end; + getout; +end; + +end. diff --git a/mail4.pas b/mail4.pas new file mode 100644 index 0000000..95bae34 --- /dev/null +++ b/mail4.pas @@ -0,0 +1,474 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail4; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, timejunk, + sysop3, + misc3, miscx, + mail0, mail1, mail2, mail3; + +procedure autoreply; +procedure readmail; + +implementation + +function extractusernum(s:string):integer; +var i:integer; +begin + i:=length(s); + while ((s[i]<>'#') and (i>1)) do dec(i); + i:=value(copy(s,i+1,5)); + extractusernum:=i; +end; + +procedure autoreply; +var i:integer; c:char; + t:text; + mheader:mheaderrec; + s:string; + brdsig,dfdt1,dfdt2,newmsgptr,totload:longint; +begin + if (lastname='') then + print('hmmm.. I am unable to auto-reply now.') + else begin + i:=extractusernum(lastname); + if (i=0) then print('It seems I can''t do that now.') else imail(i); + end; +end; + +procedure readmail; +const hellfreezesover=FALSE; +var t:text; + u:userrec; + mheader:mheaderrec; + mixr:msgindexrec; + pdt:packdatetime; + dt:ldatetimerec; + cmds,s,s1:string; + brdsig,totload:longint; + crec,i,j,k,mnum,mw,snum:integer; + c:char; + bb:byte; + abort,b,bakw,done,done1,dotitles,errs,found,hasshown1,holdit, + justdel,next,noreshow,seeanon:boolean; + + procedure findit; + var orec:integer; + abort:boolean; + begin + orec:=crec; done1:=TRUE; found:=FALSE; + if (bakw) then begin + repeat + dec(crec); abort:=(crec<0); + if (not abort) then begin + ensureloaded(crec); + mixr:=mintab[getmixnum(crec)]; + end; + until ((abort) or + ((mixr.messagenum=usernum) and (miexist in mixr.msgindexstat))); + found:=not abort; if (abort) then crec:=orec; + if (crec<>orec) then dec(mnum); + exit; + end; + repeat + inc(crec); abort:=(crec>himsg); + if (not abort) then begin + ensureloaded(crec); + mixr:=mintab[getmixnum(crec)]; + end; + until ((abort) or + ((mixr.messagenum=usernum) and (miexist in mixr.msgindexstat))); + found:=not abort; if (abort) then crec:=orec; + if (crec<>orec) then inc(mnum); + if ((justdel) and (not found)) then begin done1:=FALSE; bakw:=TRUE; end; + exit; + end; + + function tch(c:char; i:integer):string; + var s:string; + begin + s:=cstr(i); if (i<10) then s:=c+s; + tch:=s; + end; + + procedure getout; + begin + closebrd; + thisuser.waiting:=mw; + readingmail:=FALSE; + end; + +begin + readingmail:=TRUE; + abort:=FALSE; next:=FALSE; + dotitles:=TRUE; + mailread:=TRUE; + + repeat + if (dotitles) then begin + abort:=FALSE; next:=FALSE; + + nl; + hasshown1:=FALSE; + if (thisuser.waiting=0) then + sprint(#3#5+'Sorry, but you have no mail waiting.') + else begin + if (thisuser.clsmsg=1) then cls; + sprompt(#3#5+'You have '+#3#3+cstr(thisuser.waiting)+#3#5+' piece'); + if (thisuser.waiting<>1) then sprompt('s'); + sprint(' of mail waiting:'); + nl; + end; + + initbrd(-1); + i:=0; mw:=0; + while (i<=himsg) do begin + ensureloaded(i); + if ((mintab[getmixnum(i)].messagenum=usernum) and + (miexist in mintab[getmixnum(i)].msgindexstat)) then begin + inc(mw); + if (not abort) then begin + loadmhead(i,mheader); ensureloaded(i); + for j:=1 to 6 do pdt[j]:=mintab[getmixnum(i)].msgdate[j]; + pdt2dt(pdt,dt); + + with dt do begin + j:=hour; + if (j>12) then dec(j,12); + if (j=0) then j:=12; + s:=tch(' ',j)+':'+tch('0',min)+aonoff((hour>=12),'p','a'); + + s:=#3#3+copy('JanFebMarAprMayJunJulAugSepOctNovDec',(month-1)*3+1,3)+ + ' '+tch('0',day)+' '+cstr(year)+' - '+s; + end; + + s1:=what00(mheader.fromi.anon,mheader.fromi.as); + if (mheader.fromi.anon in [1,2]) then begin + case mheader.fromi.anon of + 1:seeanon:=aacs(systat.anonprivread); + 2:seeanon:=aacs(systat.csop); + end; + if (seeanon) then + s1:=s1+' ('+caps(mheader.fromi.alias)+' #'+ + cstr(mheader.fromi.usernum)+')' + else + s:=' '; + end; + + if ((not hasshown1) and (thisuser.waiting=0)) then begin + nl; sprint(#3#5+'Correction! You do have mail waiting:'); nl; + end; + + sprint(#3#0+tch(' ',mw)+#3#1+' - '+s+#3#1+' - '+#3#3+s1); + hasshown1:=TRUE; + end; + end; + inc(i); + wkey(abort,next); + end; + + if (mw<>0) then nl; + + if (thisuser.waiting<>mw) then begin + if (mw=0) then + sprint(#3#3+'You actually have no mail waiting!'); + sprint(#3#5+'Note: Discrepancy has been repaired.'); + sysoplog('Fixed discrepancy in number of private messages waiting.'); + end; + + thisuser.waiting:=mw; + if (mw=0) then begin getout; exit; end; + + abort:=FALSE; done:=FALSE; next:=FALSE; + repeat + sprompt(#3#5+'Start out with (1-'+cstr(mw)+') or (Q)uit : '+#3#9); + input(s,4); snum:=0; i:=value(s); + if ((s='ZZZZ') and (thisuser.sl=255)) then begin + nl; + sprint(#3#3+'Super Mass Delete function selected!'); + nl; + if (checkpw) then begin + prompt('Enter user PW: '); + echo:=FALSE; input(s1,20); echo:=TRUE; + if (s1=thisuser.pw) then begin + nl; nl; + if pynq('Are you absolutely totally incredibly surely sure???!!? ') then begin + nl; + print('You have selected a very powerful command.'); + print('Pause a few moments and reflect upon exactly what you are doing.'); + nl; + delay(2000); + nl; + if pynq('Now, then... do you REALLY want to do this? ') then begin + nl; + print('OK! Don''t tell me I didn''t warn you!'); + nl; + prompt('Deleting all your e-mail.... '); + i:=0; j:=0; + while (i<=himsg) do begin + ensureloaded(i); + if ((mintab[getmixnum(i)].messagenum=usernum) and + (miexist in mintab[getmixnum(i)].msgindexstat)) then begin + inc(j); + s1:=cstr(j)+' of '+cstr(mw); + prompt(s1); for k:=1 to length(s1) do prompt(^H); + delmail(i); + end; + inc(i); + end; + nl; nl; print('Done!'); + thisuser.waiting:=0; + getout; exit; + end; + end; + end; + end; + end; + if ((i>=1) and (i<=mw)) then snum:=i; + if ((s='') or (i=0)) then snum:=1; + if (copy(s,1,1)='Q') then abort:=TRUE; + done:=((abort) or (snum<>0)); + until ((done) or (hangup)); + if (abort) then begin getout; exit; end; + end; + + bakw:=FALSE; done:=FALSE; dotitles:=FALSE; + holdit:=FALSE; justdel:=FALSE; noreshow:=FALSE; + + crec:=-1; mnum:=0; + + repeat + if (not holdit) then + repeat + findit; + if (crec=-1) then begin done1:=TRUE; dotitles:=TRUE; end; + until (done1); + justdel:=FALSE; + if (mnum=snum) then snum:=0; + if ((snum=0) and (crec>=0)) then begin + next:=FALSE; + if (not noreshow) then begin + if (thisuser.clsmsg=1) then cls; + readmsg(2,crec,mnum,mw,abort,next); + end else + noreshow:=FALSE; + if (not next) then begin + prt('Read mail : '); + cmds:='Q?-ADFGIRSTN'^N; + if (cso) then cmds:=cmds+'EUVX'; + if (mso) then cmds:=cmds+'Z'; + onek(c,cmds); + end else + c:='I'; + abort:=FALSE; bakw:=FALSE; holdit:=TRUE; next:=FALSE; + case c of + '-':begin bakw:=TRUE; holdit:=FALSE; end; + 'E':if (cso) then begin + thisuser.waiting:=mw; + if (lastname<>'') then uedit(extractusernum(lastname)); + holdit:=FALSE; i:=mnum; crec:=-1; mnum:=0; snum:=i; + mw:=thisuser.waiting; + end; + 'F':begin + nl; + prt('Forward letter to which user? '); finduserws(i); + if (i<1) then print('Unknown user.') + else + if (i<>usernum) then begin + reset(uf); seek(uf,i); read(uf,u); + + j:=0; b:=TRUE; + while ((j<4) and (b)) do begin + inc(j); b:=moremail(u,i,j); + if (not b) then + case j of + 1:print('Mailbox is full.'); + 2:print('Mailbox is closed.'); + 3:if (mso) then print('That user is deleted.') + else print('Can''t send mail to that user.'); + 4:print('Can''t send mail to yourself!'); + end; + end; + + close(uf); + + if (b) then begin + mixr:=mintab[getmixnum(crec)]; mixr.messagenum:=i; + savemix(mixr,crec); + dec(thisuser.waiting); + reset(uf); + seek(uf,i); read(uf,u); inc(u.waiting); + seek(uf,i); write(uf,u); + close(uf); + sysoplog('Forwarded letter to '+caps(u.name)+' #'+cstr(i)); + dec(mw); crec:=-1; + snum:=mnum; mnum:=0; if (snum>mw) then dec(snum); + holdit:=FALSE; + end; + end; + end; + 'G':begin + prt('Goto message? (1-'+cstr(mw)+') : '); inu(i); + if ((not badini) and (i>=1) and (i<=mw)) then + begin holdit:=FALSE; crec:=-1; mnum:=0; snum:=i; end; + end; + 'I','N',^N:holdit:=FALSE; + 'Q':begin getout; exit; end; + 'R':; + 'T':dotitles:=TRUE; + 'U':if (cso) then + if (lastname<>'') then begin + noreshow:=TRUE; + nl; + i:=extractusernum(lastname); + if (i<>0) then begin + reset(uf); + errs:=((i<1) or (i>filesize(uf)-1)); + if (not errs) then begin + {$I-} seek(uf,i); read(uf,u); {$I+} + errs:=(ioresult<>0); + end; + if (errs) then + sprint(#3#7+'Unable to find "'+lastname+'" !') + else + showuserinfo(1,i,u); + nl; + close(uf); + end; + end; + 'V':if (cso) then + if (lastname<>'') then begin + noreshow:=TRUE; + nl; + i:=extractusernum(lastname); + if (i<>0) then begin + reset(uf); + errs:=((i<1) or (i>filesize(uf)-1)); + if (not errs) then begin + {$I-} seek(uf,i); read(uf,u); {$I+} + errs:=(ioresult<>0); + end; + close(uf); + if (errs) then + sprint(#3#7+'Unable to find "'+lastname+'" !') + else begin + autoval(u,i); + reset(uf); + {$I-} seek(uf,i); write(uf,u); {$I+} + close(uf); + sysoplog('Validated '+caps(u.name)+' #'+cstr(i)); + ssm(abs(mheader.fromi.usernum),^G+'You were validated on '+date+' '+time+'.'^G); + nl; + end; + end; + end; + 'X':if (mso) then begin + nl; + prt('Extract filename? (default="EXT.TXT") : '); + input(s,40); + if (s='') then s:='EXT.TXT'; + if pynq('Are you sure? ') then begin + b:=pynq('Strip color codes from output? '); + + loadmhead(crec,mheader); + + assign(t,s); + {$I-} append(t); {$I+} + if (ioresult<>0) then rewrite(t); + totload:=0; + repeat + blockreadstr2(brdf,s); + inc(totload,length(s)+2); + if ((b) and (pos(#3,s)<>0)) then s:=stripcolor(s); + writeln(t,s); + until (totload>=mheader.msglength); + close(t); + + nl; + print('Done!'); + end; + end; + 'A','S', + 'D','Z':begin + b:=TRUE; + if (c in ['A','S']) then begin + reset(uf); + loadmhead(crec,mheader); + i:=mheader.fromi.usernum; + if ((i>=1) and (i<=filesize(uf)-1)) then begin + seek(uf,i); read(uf,u); + end; + + j:=0; b:=TRUE; + while ((j<4) and (b)) do begin + inc(j); b:=moremail(u,i,j); + if (not b) then + case j of + 1:print('That user''s mailbox is full.'); + 2:print('That user''s mailbox is closed.'); + 3:if (mso) then print('That user is deleted.') + else print('Can''t send mail to that user.'); + 4:print('Can''t send mail to yourself!'); + end; + end; + close(uf); + end; + + if (b) then begin + if ((c='Z') and (not mso)) then c:='D'; + case c of + 'D':ssm(abs(mheader.fromi.usernum), + nam+' read your letter on '+date+' '+time+'.'); + 'A','S':ssm(abs(mheader.fromi.usernum), + nam+' replied to your letter on '+date+' '+time+'.'); + end; + if (c<>'S') then begin + s:=rmail(crec); + dec(mw); crec:=-1; + snum:=mnum; mnum:=0; if (snum>mw) then dec(snum); + holdit:=FALSE; + end; + end; + end; + '?':begin + nl; + lcmds(19,3,'Title listing',''); + lcmds(19,3,'Ignore letter','-Previous letter'); + lcmds(19,3,'Goto letter','Forward letter to other user'); + lcmds(19,3,'Delete letter','Auto-reply to author'); + lcmds(19,3,'Re-read letter','Store and reply (save original)'); + if (cso) then + lcmds(19,5,'User info/author','Edit author''s account'); + if (cso) then + lcmds(19,5,'Validate author','Zap (delete w/o receipt)') + else + if (mso) then + lcmds(19,5,'Zap letter',''); + if (mso) then + lcmds(50,5,'Xtract msg to file',''); + lcmds(19,9,'Quit Mail',''); + nl; + noreshow:=TRUE; + end; + end; + if (c in ['A','S']) then begin + i:=thisuser.waiting; + autoreply; inc(mw,thisuser.waiting-i); + end; + end; + if ((mw=0) or ((crec=-1) and (snum=0))) then done:=TRUE; + until ((done) or (dotitles) or (hangup)); + if (done) then begin getout; exit; end; + until (hellfreezesover); + + getout; { just in case hell freezes over! } +end; + +end. diff --git a/mail5.pas b/mail5.pas new file mode 100644 index 0000000..f294385 --- /dev/null +++ b/mail5.pas @@ -0,0 +1,728 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail5; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, timejunk, + sysop4, + mail0, mail1, mail2, mail3, mail4, mail6; + +procedure post(replyto:longint; ttoi:fromtoinfo); +procedure scanmessages; +procedure qscan(b:integer; var quit:boolean); +procedure gnscan; +procedure nscan(mstr:string); + +implementation + +procedure post(replyto:longint; ttoi:fromtoinfo); +var pinfo:pinforec; + mheader:mheaderrec; + mixr,mixr2:msgindexrec; + saveit:string; + itreepos,lng,otreepos:longint; + i:integer; + numread:word; + savilevel:byte; + ok:boolean; + + procedure nope(s:string); + begin + if (ok) then begin nl; print(s); end; + ok:=FALSE; + end; + +begin + ok:=TRUE; + loadboard(board); + if (not aacs(memboard.postacs)) then + nope('Your access does not allow you to post on this board.'); + if ((rpost in thisuser.ac) or (not aacs(systat.normpubpost))) then + nope('Your access privledges do not include posting.'); + if ((ptoday>=systat.maxpubpost) and (not mso)) then + nope('Too many messages posted today.'); + if (ok) then begin + savepinfo(pinfo); + initbrd(board); + + saveit:=''; + if (replyto<>-1) then begin + mheader.toi:=ttoi; + if (mheader.toi.anon<>0) then begin + saveit:=mheader.toi.as; + mheader.toi.as:=what00(mheader.toi.anon,mheader.toi.as); + end; + end else + mheader.toi.as:=''; + + if (inmsg(TRUE,(replyto<>-1),'',mixr,mheader)) then begin + if (saveit<>'') then mheader.toi.as:=saveit; + seek(brdf,mixr.hdrptr); + savemhead(mheader); + + if (replyto<>-1) then begin + mixr.isreplyto:=replyto; + mixr.numreplys:=0; + mixr.msgindexstat:=mixr.msgindexstat+[mithreads]; + ensureloaded(replyto); + mixr2:=mintab[getmixnum(replyto)]; + mixr.isreplytoid:=mixr2.msgid; + inc(mixr2.numreplys); + mixr2.msgindexstat:=mixr2.msgindexstat+[mithreads]; + ensureloaded(replyto); + savemix(mixr2,replyto); + ensureloaded(replyto); + end; + + newmix(mixr); + ensureloaded(himsg); + + sysoplog('+ "'+mheader.title+'" posted on '+#3#5+memboard.name); + if (mheader.toi.as<>'') then sysoplog(' To: "'+mheader.toi.as+'"'); + + topscr; + sprint(#3#9+'Message posted on '+#3#5+memboard.name+#3#9+'.'); + + inc(thisuser.msgpost); + inc(ptoday); + inc(systat.todayzlog.pubpost); + end; + loadpinfo(pinfo); + end; +end; + +function isnew1(msgdatepp:packdatetimepp):boolean; +var msgdate:packdatetime; + l1,l2,l3:longint; + + function zzzb(xx,yy:longint):longint; + begin xx:=xx shl yy; zzzb:=xx; end; + +begin + msgdate:=msgdatepp^; + isnew1:=FALSE; + with zscanr do begin + l1:=zzzb(msgdate[1],16); + inc(l1,zzzb(msgdate[2],8)); + inc(l1,msgdate[3]); + l2:=zzzb(mhiread[board][1],16); + inc(l2,zzzb(mhiread[board][2],8)); + inc(l2,mhiread[board][3]); + if (l1=mheader.msglength); + close(t); + + tedit(allcaps('tgtempx.msg')); + begin + assign(t,'tgtempx.msg'); + reset(t); + mheader.msglength:=0; + repeat + readln(t,s); + inc(mheader.msglength,length(s)+2); + until (eof(t)); + close(t); + newmsgptr:=filesize(brdf); + seek(brdf,newmsgptr); + outmessagetext('tgtempx.msg',mheader,TRUE); + ensureloaded(i); + mixr:=mintab[getmixnum(i)]; + mixr.hdrptr:=newmsgptr; + savemix(mixr,i); + ensureloaded(i); + end; +end; + +procedure pubreply(cn:word); +var t:text; + mheader:mheaderrec; + s:string; + brdsig,dfdt1,dfdt2,newmsgptr,totload:longint; +begin + if (gotlastmheader) then begin + loadmhead(cn,mheader); + + assign(t,'msgtmp'); rewrite(t); + totload:=0; + repeat + blockreadstr2(brdf,s); + inc(totload,length(s)+2); + writeln(t,s); + until (totload+1>=mheader.msglength); + close(t); + + post(cn,lastmheader.fromi); + + assign(t,'msgtmp'); + {$I-} reset(t); {$I+} + if (ioresult=0) then begin close(t); erase(t); end; + end else begin + nl; print('Can''t reply YET.'); nl; + end; +end; + +type + mstype = + (msreadp, { read prompt } + msshowt, { show titles } + msreadm); { read message } + + sttype = + (stnewscan, { NewScan mode } + stscan); { normal Scan mode } + +procedure doscan(var quit:boolean; cn:word; st:sttype; ms:mstype); +var t:text; + u:userrec; + mheader:mheaderrec; + mixr:msgindexrec; + lastdate:packdatetime; + inp,s:string; + brdsig,getm,totload:longint; + i,j,k:integer; + cmd:char; + abort,askpost,b,contlist,donescan,hadunval,next,ufo,wasout,zup:boolean; + + procedure cbounds; + begin + wasout:=((cn<0) or (cn>himsg)); + if (not wasout) then exit; + if (cn>himsg) then cn:=himsg + else if (cn<0) then cn:=0; + end; + + function tch(c:char; i:integer):string; (* duplicate.... MARTIN HANDLE THIS!*) + var s:string; + begin + s:=cstr(i); if (i<10) then s:=c+s; + tch:=s; + end; + + procedure stitles; + var mheader:mheaderrec; + dt:ldatetimerec; + pdt:packdatetime; + s,real,alias:string; + i,j,numdone:word; + abort,ndone,next:boolean; + begin + nl; + ndone:=TRUE; + abort:=FALSE; numdone:=0; + cbounds; if (wasout) then exit; + while ((not hangup) and (not abort) and (numdone<10) and (ndone)) do begin + cbounds; if (wasout) then ndone:=FALSE; + if (ndone) then begin + loadmhead(cn,mheader); ensureloaded(cn); + i:=cn; + with mheader do begin + real:=allcaps(thisuser.realname); + alias:=allcaps(thisuser.name); + if ((fromi.usernum=usernum) or + (allcaps(copy(fromi.as,1,length(real)))=real) or + (allcaps(copy(fromi.alias,1,length(alias)))=alias)) then + s:=#3#9+'['+#3#5+cstr(i+1)+#3#9+']' + else if ((toi.usernum=usernum) or + (allcaps(copy(toi.as,1,length(real)))=real) or + (allcaps(copy(toi.alias,1,length(alias)))=alias)) then + s:=#3#9+'<'+#3#5+cstr(i+1)+#3#9+'>' + else + s:=#3#7+'('+#3#5+cstr(i+1)+#3#7+')'; + end; + + for j:=1 to 6 do pdt[j]:=mintab[getmixnum(cn)].msgdate[j]; + pdt2dt(pdt,dt); + s:=#3#1+mrn(s,8)+#3#3+' '+mrn(cstr(dt.month),2)+'/'+ + tch('0',dt.day)+'/'+copy(tch('0',dt.year),3,2)+' - '; + + if (isnew(cn)) then begin + delete(s,1,3); + s:=#3#8+'*'+s; + end; + if (miunvalidated in mintab[getmixnum(cn)].msgindexstat) then begin + if (mso) then begin + delete(s,1,4); + s:=#3#8+'NV'+s; + end else + s:=s+#3#8+'<>'; + end; + if ((not (miunvalidated in mintab[getmixnum(cn)].msgindexstat)) or + (mso)) then s:=s+mheader.title; + + if (miallowmci in mintab[getmixnum(cn)].msgindexstat) then sprint(s) + else printacr(s,abort,next); + + wkey(abort,next); + inc(numdone); + inc(cn); + end; + end; + dec(cn); + nl; + end; + + procedure scaninput(var s:string; allowed:string); + var os:string; + i:integer; + c:char; + gotcmd:boolean; + begin + gotcmd:=FALSE; s:=''; + repeat + getkey(c); c:=upcase(c); + os:=s; + if ((pos(c,allowed)<>0) and (s='')) then begin gotcmd:=TRUE; s:=c; end + else + if (pos(c,'0123456789')<>0) then begin + if (length(s)<5) then s:=s+c; + end + else + if ((s<>'') and (c=^H)) then s:=copy(s,1,length(s)-1) + else + if (c=^X) then begin + for i:=1 to length(s) do prompt(^H' '^H); + s:=''; os:=''; + end + else + if (c=#13) then gotcmd:=TRUE; + + if (length(s)length(os)) then prompt(copy(s,length(s),1)); + until ((gotcmd) or (hangup)); + nl; + end; + +begin + askpost:=FALSE; contlist:=FALSE; donescan:=FALSE; hadunval:=FALSE; + zup:=FALSE; + + while ((not donescan) and (not hangup)) do begin + getm:=-1; + if (ms=msshowt) then begin stitles; ms:=msreadp; end; + if (ms=msreadp) then begin + msg_on:=cn+1; + cbounds; + ensureloaded(cn); + + if ((contlist) and (not abort)) then + if (cn=himsg) then abort:=TRUE; + + if ((not contlist) or (abort)) then begin + if (contlist) then begin + contlist:=FALSE; + nl; print('Continuous message listing Off'); nl; + end; + sprompt(fstring.scanmessage); + scaninput(inp,'ABCDEHMPQRTVWXZ-*!&?'); + end else + inp:=''; + + getm:=-1; cmd:=#0; + + if (inp='') then getm:=cn+1 else begin + getm:=value(inp)-1; + if (getm>-1) then + if (st=stnewscan) then st:=stscan; + end; + + if ((getm=-1) and (inp<>'')) then cmd:=inp[1]; + + case cmd of + 'R':getm:=cn; + '-':begin + getm:=cn-1; + if (getm=-1) then begin + nl; sprint('Already at the first message.'); nl; + end; + if (st=stnewscan) then st:=stscan; + end; + end; + if ((getm=-1) and (cmd<>#0)) then + case cmd of + '?':begin + nl; + sprint('<^3CR^1>Next message ^3#^1:Message to read'); + sprint('(^3-^1)Prev. message (^3C^1)ontinuous listing'); + nl; + sprint('(^3A^1)uto-reply (pub/priv) (^3B^1)Next board in NewScan'); + sprint('(^3P^1)ost public (^3H^1)igh message pointer'); + sprint('(^3R^1)e-read (^3T^1)itles'); + sprint('(^3W^1)rite public reply (^3Z^1)Toggle NewScan of this base'); + nl; + s:='(^5E^1)dit message (owner only)'; + if (mso) then + s:=s+' (^5D^1)elete message (SysOp only)'; + sprint(s); + if (mso) then begin + sprint('(^5V^1)alidation toggle (^5M^1)ove msg to other base'); + sprint('(^5X^1)tract message to file (^5!^1)Toggle permanence'); + if (cso) then begin + s:='(^7*^1)Toggle anonymous'; + if (memboard.mbtype<>0) then s:=s+' (^7&^1)Toggle scanned/outbound'; + sprint(s); + end; + nl; + end; + sprint('(^3Q^1)uit'); + nl; + end; + 'A':begin + nl; + if pynq('Is this to be a private reply? ') then autoreply + else pubreply(cn); + end; + 'B':donescan:=TRUE; + 'C':begin + contlist:=TRUE; abort:=FALSE; + nl; print('Continuous message listing On'); nl; + end; + 'D':if (mipermanent in mintab[getmixnum(cn)].msgindexstat) then begin + nl; print('This is a permanent message.'); nl; + end else begin + loadmhead(cn,mheader); + if ((mso) and (cn>=0) and (cn<=himsg)) then begin + delmail(cn); + nl; + if (miexist in mintab[getmixnum(cn)].msgindexstat) then begin + print('Undeleted message.'); + sysoplog('* Undeleted "'+mheader.title+'"'); + end else begin + print('Deleted message.'); + sysoplog('* Deleted "'+mheader.title+'"'); + end; + nl; + end else begin + nl; print('Sorry... can''t delete that!'); nl; + end; + + if (cn>himsg) then cn:=himsg; + if (himsg<=0) then begin donescan:=TRUE; askpost:=TRUE; end; + end; + 'E':if ((mso) and (lastname<>'')) then + editmessage(cn) + else begin + loadmhead(cn,mheader); + if ((mheader.fromi.usernum=usernum) and + (allcaps(mheader.fromi.real)= + allcaps(thisuser.realname))) then + editmessage(cn) + else begin + nl; + print('You didn''t post this message!'); + nl; + end; + end; + 'H':begin + nl; + i:=cn; + print('Highest-read pointer for this base set to message #'+ + cstr(i+1)+'.'); + nl; + for i:=1 to 6 do + zscanr.mhiread[board][i]:=mintab[getmixnum(cn)].msgdate[i]; + savezscanr; + end; + 'M':if (mso) then movemsg(cn); + 'P':begin post(-1,mheader.fromi); nl; end; + 'Q':begin quit:=TRUE; donescan:=TRUE; end; + 'T':ms:=msshowt; + 'V':if (mso) then begin + loadmhead(cn,mheader); mixr:=mintab[getmixnum(cn)]; + if (miunvalidated in mixr.msgindexstat) then begin + nl; print('Message validated.'); nl; + mixr.msgindexstat:=mixr.msgindexstat-[miunvalidated]; + sysoplog('* Validated "'+mheader.title+'"'); + end else begin + nl; print('Message unvalidated.'); nl; + mixr.msgindexstat:=mixr.msgindexstat+[miunvalidated]; + sysoplog('* Unvalidated "'+mheader.title+'"'); + end; + savemix(mixr,cn); + end; + 'W':pubreply(cn); + 'X':if (mso) then begin + nl; + prt('Extract filename? (default="EXT.TXT") : '); + input(s,40); + if (s='') then s:='EXT.TXT'; + if pynq('Are you sure? ') then begin + b:=pynq('Strip color codes from output? '); + + loadmhead(cn,mheader); + + assign(t,s); + {$I-} append(t); {$I+} + if (ioresult<>0) then rewrite(t); + totload:=0; + repeat + blockreadstr2(brdf,s); + inc(totload,length(s)+2); + if ((b) and (pos(#3,s)<>0)) then s:=stripcolor(s); + writeln(t,s); + until (totload>=mheader.msglength); + close(t); + + nl; + print('Done!'); + end; + end; + 'Z':begin + nl; + sprompt(#3#5+memboard.name+#3#3); + if (board in zscanr.mzscan) then begin + zscanr.mzscan:=zscanr.mzscan-[board]; + sprint(' will NOT be scanned in future NewScans.'); + sysoplog('* Took "'+#3#5+memboard.name+#3#1+'" out of NewScan'); + end else begin + zscanr.mzscan:=zscanr.mzscan+[board]; + sprint(' WILL be scanned in future NewScans.'); + sysoplog('* Put "'+#3#5+memboard.name+#3#1+'" back in NewScan'); + end; + nl; + savezscanr; + end; + '!':if (mso) then begin + nl; + loadmhead(cn,mheader); mixr:=mintab[getmixnum(cn)]; + if (mipermanent in mixr.msgindexstat) then begin + mixr.msgindexstat:=mixr.msgindexstat-[mipermanent]; + print('Message is no longer permanent.'); + sysoplog('* "'+mheader.title+'" made unpermanent'); + end else begin + mixr.msgindexstat:=mixr.msgindexstat+[mipermanent]; + print('Message is now permanent.'); + sysoplog('* "'+mheader.title+'" made permanent'); + end; + savemix(mixr,cn); + nl; + end; + '*':if (cso) then begin + nl; + j:=getmixnum(cn); loadmhead(j,mheader); + if (mheader.fromi.anon in [1,2]) then + mheader.fromi.anon:=0 + else begin + i:=mheader.fromi.usernum; + ufo:=(filerec(uf).mode<>fmclosed); + if (not ufo) then reset(uf); + if ((i>=1) and (i<=filesize(uf)-1)) then begin + seek(uf,i); read(uf,u); + b:=aacs1(u,i,systat.csop); + end else + b:=FALSE; + if (not ufo) then close(uf); + if (b) then mheader.fromi.anon:=2 else mheader.fromi.anon:=1; + end; + seek(brdf,mintab[j].hdrptr); + savemhead(mheader); + if (mheader.fromi.anon=0) then begin + print('Message is no longer anonymous.'); + sysoplog('* "'+mheader.title+'" made non-anonymous'); + end else begin + print('Message is now anonymous.'); + sysoplog('* "'+mheader.title+'" made anonymous'); + end; + nl; + end; + '&':if ((cso) and (memboard.mbtype<>0)) then begin + nl; + loadmhead(cn,mheader); mixr:=mintab[getmixnum(cn)]; + if (miscanned in mixr.msgindexstat) then begin + mixr.msgindexstat:=mixr.msgindexstat-[miscanned]; + print('Message is no longer marked as scanned.'); + sysoplog('* "'+mheader.title+'" not marked as scanned'); + end else begin + mixr.msgindexstat:=mixr.msgindexstat+[miscanned]; + print('Message is now marked as "sent".'); + sysoplog('* "'+mheader.title+'" marked as scanned'); + end; + savemix(mixr,cn); + nl; + end; + end; + end; + + if (getm<>-1) then cn:=getm; + cbounds; + if (wasout) then + if (not contlist) then begin + donescan:=TRUE; + if (ms=msreadp) then askpost:=TRUE; + end else + contlist:=FALSE; + + if (not donescan) then begin + if (getm<>-1) then ms:=msreadm; + if (ms=msreadm) then begin + if (contlist) then next:=TRUE; + if ((thisuser.clsmsg=1) and (not contlist)) then cls; + if (miunvalidated in mintab[getmixnum(cn)].msgindexstat) then + hadunval:=TRUE; + readmsg(1,cn,cn+1,himsg+1,abort,next); + updateptr(cn,zup); + for i:=1 to 6 do lastdate[i]:=mintab[getmixnum(cn)].msgdate[i]; + if (not next) then ms:=msreadp else inc(cn); + inc(mread); + end; + end; + end; + + if ((hadunval) and (mso)) then begin + nl; + if pynq(^G'Validate messages here? ') then + for i:=0 to himsg do begin + ensureloaded(i); mixr:=mintab[getmixnum(i)]; + if (miunvalidated in mixr.msgindexstat) then begin + mixr.msgindexstat:=mixr.msgindexstat-[miunvalidated]; + savemix(mixr,i); + end; + end; + end; + if ((askpost) and (aacs(memboard.postacs)) and + (not (rpost in thisuser.ac)) and (ptoday-1) then begin + sprint(cstr(himsg+1)+' msgs on '+#3#5+memboard.name+#3#1+'.'); + prt('Start listing at (Q=Quit)? '); input(s,20); + i:=value(s)-1; cn:=0; + if (i<0) then i:=0 else + if (i<=himsg) then cn:=i; + if (s<>'') then c:=s[1] else c:=^M; + if (c<>'Q') then doscan(quit,cn,stscan,msshowt); + end else + sprint('No messages on '+#3#5+memboard.name+#3#1+'.'); + closebrd; +end; + +procedure qscan(b:integer; var quit:boolean); +var cn:word; + oldboard,savlil,i:integer; + abort,next:boolean; +begin + oldboard:=board; + if (not quit) then begin + if (board<>b) then changeboard(b); + if (board=b) then begin + nl; + initbrd(board); + lil:=0; sprompt(#3#3+fstring.newscan1); + if (himsg<>-1) then begin + cn:=0; + while ((not isnew(cn)) and (cn<=himsg)) do inc(cn); + if ((cn<=himsg) and (isnew(cn))) then doscan(quit,cn,stnewscan,msreadm) + else quit:=FALSE; + end; + closebrd; + if (not quit) then begin + lil:=0; + sprompt(fstring.newscan2); + end; + end; + wkey(quit,next); + end; + board:=oldboard; +end; + +procedure gnscan; +var bb,oldboard:integer; + quit:boolean; +begin + sysoplog('NewScan of message bases'); + oldboard:=board; + nl; sprint(#3#5+')[ NewScan All ]('); + bb:=1; quit:=FALSE; + repeat + if (bb in zscanr.mzscan) then qscan(bb,quit); + inc(bb); + until ((bb>numboards) or (quit) or (hangup)); + nl; sprint(#3#5+')[ NewScan Done ]('); + board:=oldboard; + initbrd(board); +end; + +procedure nscan(mstr:string); +var abort,next:boolean; +begin + abort:=FALSE; next:=FALSE; + if (mstr='C') then qscan(board,next) + else if (mstr='G') then gnscan + else if (value(mstr)<>0) then qscan(value(mstr),next) + else begin + nl; + if pynq('Global NewScan? ') then gnscan else qscan(board,next); + end; +end; + +end. diff --git a/mail6.pas b/mail6.pas new file mode 100644 index 0000000..5761616 --- /dev/null +++ b/mail6.pas @@ -0,0 +1,372 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail6; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, + mail0, mail3, mail9, msgpack; + +procedure movemsg(x:integer); +procedure mailr; +procedure dopurgepub(cms:string); +procedure purgepriv; +procedure doshowpackbases; +procedure packmessagebases; +procedure chbds; + +implementation + +procedure movemsg(x:integer); +var f:file; + pinfo:pinforec; + mheader:mheaderrec; + mixr:msgindexrec; + s:string; + brdsig,totload:longint; + i,oldboard:integer; + done:boolean; +begin + nl; + if ((x>=0) and (x<=himsg)) then begin + i:=0; done:=FALSE; + repeat + prt('Enter board #, (?)List, or (Q)uit : '); input(s,3); + if ((s='') or (s='Q')) then done:=TRUE + else + if (s='?') then begin mbaselist; nl; end + else begin + i:=ccboards[0][value(s)]; + if ((i>=1) and (i<>board) and (i<=numboards)) then done:=TRUE; + if (not done) then print('Can''t move it there.'); + end; + until ((done) or (hangup)); + if ((i>=1) and (i<=numboards)) then begin + oldboard:=board; + changeboard(i); + if (board=i) then begin + board:=oldboard; + ensureloaded(x); mixr:=mintab[getmixnum(x)]; + loadmhead(x,mheader); + + savepinfo(pinfo); + assign(f,systat.msgpath+brdfnopen+'.BRD'); reset(f,1); + initbrd(i); + + seek(f,mixr.hdrptr); + blockread(f,mheader,sizeof(mheaderrec)); + + mixr.hdrptr:=filesize(brdf); + mheader.msgptr:=mixr.hdrptr+sizeof(mheaderrec); + seek(brdf,mixr.hdrptr); + blockwrite(brdf,mheader,sizeof(mheaderrec)); + + totload:=0; + repeat + blockreadstr2(f,s); + blockwritestr2(brdf,s); + inc(totload,length(s)+2); + until (totload>=mheader.msglength); + + savemhead(mheader); + newmix(mixr); + + loadpinfo(pinfo); + changeboard(oldboard); + delmail(x); + + print('Move successful.'); + nl; + end; + end; + end; +end; + +procedure mailr; +var mixr:msgindexrec; + i,j:integer; + c:char; + abort,next,gonext,contlist:boolean; +begin + readingmail:=TRUE; + contlist:=FALSE; gonext:=FALSE; + initbrd(-1); + i:=himsg; c:=#0; + if ((thisuser.clsmsg<>1) and (i>=0)) then nl; + while ((i>=0) and (c<>'Q') and (not hangup)) do begin + ensureloaded(i); mixr:=mintab[getmixnum(i)]; + gonext:=FALSE; + repeat + if (c<>'?') then begin + if ((thisuser.clsmsg=1) and (not contlist)) then cls; + readmsg(3,i,i,himsg,abort,next); + end; + if (not contlist) or ((abort) and (not next)) then begin + if (contlist) then begin + print('Continuous message listing off.'); nl; + contlist:=FALSE; + end; + prt('Mail read (?=help) : '); onek(c,'Q-CDGILNR?'^M^N); + end else + c:='I'; + case c of + '?':begin + nl; + sprint('<^3CR^1>Next message'); + lcmds(20,3,'Ignore message','-Previous message'); + lcmds(20,3,'Goto message','Continuous listing'); + lcmds(20,3,'Re-read message','Delete message'); + lcmds(20,3,'Quit',''); + nl; + end; + '-':if (i=0) and (j<=himsg)) then i:=j; + end; + 'R':; + else + gonext:=TRUE; + end; + until ((pos(c,'?LR')=0) or (gonext) or (hangup)); + if (gonext) then dec(i); + gonext:=FALSE; + end; + closebrd; + readingmail:=FALSE; +end; + +procedure purgepub(global:boolean); +var oldboard:integer; + abort,next:boolean; + + procedure purgeit; + var mheader:mheaderrec; + mixr:msgindexrec; + pc:string; + cn:integer; + c:char; + begin + abort:=FALSE; next:=FALSE; + nl; + initbrd(board); + sprint(#3#3+'[--> Purge '+#3#5+memboard.name+#3#3' <--]'); + cn:=0; c:=#0; + while ((cn<=himsg) and (not abort) and (not hangup)) do begin + ensureloaded(cn); mixr:=mintab[getmixnum(cn)]; loadmhead(cn,mheader); + if (mheader.fromi.usernum<>usernum) then + inc(cn) + else begin + if (c<>'?') then readmsg(4,cn,cn+1,himsg+1,abort,next); + if (not next) then begin + pc:='QDIR?'^M^N; + if (global) then pc:=pc+'B'; + prt('Purge posts (?=help) : '); onek(c,pc); + end else + c:='I'; + case c of + '?':begin + nl; + sprint('<'+#3#3+'CR'+#3#1+'>Next msg'); + lcmds(12,3,'Re-read msg','Ignore (next msg)'); + if (global) then + lcmds(12,3,'Delete msg','BNext board in purge') + else + lcmds(12,3,'Delete msg',''); + lcmds(12,3,'Quit',''); + nl; + end; + 'D':if (mipermanent in mixr.msgindexstat) then + print('This is a permanent message.') + else begin + if (miexist in mixr.msgindexstat) then + sysoplog('- "'+mheader.title+'" purged off '+ + #3#5+memboard.name) + else + sysoplog('+ "'+mheader.title+'" unpurged on '+ + #3#5+memboard.name); + delmail(cn); + end; + ^M,^N,'I':inc(cn); + 'B','Q':begin + abort:=TRUE; cn:=himsg+1; + if (c='B') then next:=TRUE; + end; + end; + end; + end; + nl; + sprint(#3#4+'[--> '+#3#5+memboard.name+#3#4+' Purge DONE <--]'); + closebrd; + end; + + procedure globalpurge; + var i:integer; + begin + nl; + sprint(#3#7+')>=- Global Purge -=<('); + i:=1; changeboard(i); + repeat + if ((mbaseac(board)) and (board=i)) then purgeit; + inc(i); changeboard(i); + if (next) then abort:=FALSE; + until ((i>numboards) or (abort) or (hangup)); + nl; + sprint(#3#7+'[> Global Purge COMPLETE <]'); + end; + +begin + oldboard:=board; + if (global) then globalpurge else purgeit; + board:=oldboard; +end; + +procedure dopurgepub(cms:string); +var i:integer; +begin + if (cms='C') then purgepub(FALSE) + else if (cms='G') then purgepub(TRUE) + else if (value(cms)<>0) then begin + i:=board; + changeboard(value(cms)); + if (board=value(cms)) then purgepub(FALSE); + changeboard(i); + end else begin + nl; + purgepub(pynq('Global purge? ')); + end; +end; + +procedure purgepriv; +var mheader:mheaderrec; + mixr:msgindexrec; + i:integer; + c:char; + abort,done,next:boolean; +begin + readingmail:=TRUE; done:=FALSE; + nl; + initbrd(-1); + i:=0; c:=#0; + while ((i<=himsg) and (not done) and (not hangup)) do begin + ensureloaded(i); mixr:=mintab[getmixnum(i)]; loadmhead(i,mheader); + if (mheader.fromi.usernum<>usernum) then + inc(i) + else begin + if (c<>'?') then begin + if ((thisuser.clsmsg=1) and (not contlist)) then cls; + readmsg(4,i,i+1,himsg+1,abort,next); + end; + prt('Delete mail (?=help) : '); onek(c,'QDINR?'^M^N); + case c of + '?':begin + nl; + sprint('<^3CR^1>Next message'); + lcmds(20,3,'Re-read message','Ignore (next message)'); + lcmds(20,3,'Delete message','Quit'); + nl; + end; + 'Q':done:=TRUE; + 'D':if (miexist in mixr.msgindexstat) then begin + sysoplog('* Deleted mail to '+rmail(i)); + print('Mail deleted.'); + end else begin + sysoplog('* Undeleted mail to '+rmail(i)); + print('Mail undeleted.'); + end; + else + inc(i); + end; + end; + end; + closebrd; topscr; + readingmail:=FALSE; +end; + +procedure doshowpackbases; +var tempboard:boardrec; + i:integer; + b:boolean; +begin + b:=(pause in thisuser.ac); + thisuser.ac:=thisuser.ac-[pause]; + nl; + sysoplog('Packed all message bases'); + sprint(#3#4+'þþ '+#3#3+'Packing all message bases '+#3#4+'þþ'); + nl; + sprint(#3#1+'Packing '+#3#5+'Private Mail'); packbase('email',0); + reset(bf); + for i:=0 to filesize(bf)-1 do begin + reset(bf); seek(bf,i); read(bf,tempboard); + sprint(#3#1+'Packing '+#3#5+tempboard.name+#3#5+' #'+cstr(i+1)); + packbase(tempboard.filename,tempboard.maxmsgs); + end; + reset(bf); close(bf); + lil:=0; + if (b) then thisuser.ac:=thisuser.ac+[pause]; +end; + +procedure packmessagebases; +begin + nl; + if pynq('Pack all message bases? ') then doshowpackbases else begin + with memboard do begin + sysoplog('Packed message base '+#3#5+memboard.name); + nl; sprint(#3#1+'Packing '+#3#5+name+#3#5+' #'+cstr(ccboards[1][board])); + packbase(filename,maxmsgs); + end; + end; +end; + +procedure chbds; +var s:astr; + i:integer; + done:boolean; +begin + nl; + if (novice in thisuser.ac) then begin mbaselist; nl; end; + done:=FALSE; + repeat + prt('Set NewScan message bases (Q=Quit,?=List,#=Toggle base) : '); input(s,3); + if (s='Q') then done:=TRUE; + if (s='?') then begin mbaselist; nl; end; + i:=ccboards[0][value(s)]; + if (mbaseac(i)) then { loads memboard } + if (i>=1) and (i<=numboards) and + (length(s)>0) and (s[1] in ['0'..'9']) then begin + nl; + sprompt(#3#5+memboard.name+#3#3); + if (i in zscanr.mzscan) then begin + sprint(' will NOT be scanned.'); + zscanr.mzscan:=zscanr.mzscan-[i]; + end else begin + sprint(' WILL be scanned.'); + zscanr.mzscan:=zscanr.mzscan+[i]; + end; + nl; + end; + until (done) or (hangup); + lastcommandovr:=TRUE; + savezscanr; +end; + +end. diff --git a/mail9.pas b/mail9.pas new file mode 100644 index 0000000..21608d6 --- /dev/null +++ b/mail9.pas @@ -0,0 +1,340 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mail9; + +interface + +uses + crt, dos, + + {rcg11172000 no overlay under Linux.} + {overlay,} + + common, timejunk, mail0, mail4; + +procedure mbaselist; +procedure mbasechange(var done:boolean; mstr:astr); +procedure readamsg; +procedure wamsg; +procedure replyamsg; +procedure mbasestats; + +implementation + +procedure mbaselist; +var s,os:astr; + b,b2,i,onlin,nd:integer; + abort,next,acc,showtitles:boolean; + + procedure titles; + var sep:astr; + begin + sep:=#3#4+':'+#3#3; + if (showtitles) then begin + sprint(#3#3+'NNN'+sep+'Flags '+sep+'Type '+sep+'Description'); + sprint(#3#4+'ÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ='); + showtitles:=FALSE; + end; + end; + + procedure longlist; + var s1:string[5]; + begin + nl; + showtitles:=TRUE; + s1:=' '; + while ((b<=numboards) and (not abort)) do begin + acc:=mbaseac(b); + if ((mbunhidden in memboard.mbstat) or (acc)) then begin + titles; + if (acc) then begin + s:=#3#5+cstr(ccboards[1][b]); + while (length(s)<6) do s:=s+' '; + if (b in zscanr.mzscan) then s:=s+#3#9+'Scan ' else s:=s+#3#9+s1; + end else + s:=#3#9+' '; + if (not (mbfilter in memboard.mbstat)) then s:=s+'ANSI ' else s:=s+s1; + if (mbrealname in memboard.mbstat) then s:=s+'Real ' else s:=s+s1; + case memboard.mbtype of + 0:s:=s+#3#3+'Local '+#3#5; + 1:s:=s+#3#3+'Echo '+#3#0; + 2:s:=s+#3#3+'Group '+#3#0; + end; + s:=s+memboard.name; + sprint(s); + inc(nd); + if (not empty) then wkey(abort,next); + end; + inc(b); + end; + end; + + procedure shortlist; + begin + nl; + while ((b<=numboards) and (not abort)) do begin + acc:=mbaseac(b); + if ((mbunhidden in memboard.mbstat) or (acc)) then begin + if (acc) then begin + b2:=ccboards[1][b]; + if (memboard.mbtype=0) then s:=#3#5 else s:=#3#0; + if (b2<10) then s:=s+' '; s:=s+cstr(b2); + if (b in zscanr.mzscan) then s:=s+'* ' else s:=s+' '; + end else + s:=' '; + s:=s+#3#5+memboard.name; + inc(onlin); inc(nd); + if (onlin=1) then begin + if (lennmci(s)<=40) then s:=mlnmci(s,40); + sprompt(s); os:=s; + if (lennmci(s)>40) then begin nl; onlin:=0; end; + end else begin + os:=''; + if (thisuser.linelen>=80) then begin + if (lennmci(s)>40) then begin nl; os:=''; end; + end else nl; + sprint(os+s); + onlin:=0; + end; + if (not empty) then wkey(abort,next); + end; + inc(b); + end; + if ((onlin=1) and (thisuser.linelen>=80)) then nl; + end; + +begin + nl; + abort:=FALSE; + onlin:=0; s:=''; b:=1; nd:=0; + if pynq('Display detailed area listing? ') then longlist else shortlist; + if (nd=0) then sprompt(#3#7+'No message bases.'); +end; + +procedure mbasechange(var done:boolean; mstr:astr); +var s:astr; + i:integer; +begin + if mstr<>'' then + case mstr[1] of + '+':begin + i:=board; + if (board>=numboards) then i:=0 else + repeat + inc(i); + changeboard(i); + until (board=i) or (i>numboards); + if (board<>i) then sprint('@MHighest accessible message base.') + else lastcommandovr:=TRUE; + end; + '-':begin + i:=board; + if board<=0 then i:=numboards else + repeat + dec(i); + changeboard(i); + until (board=i) or (i<=0); + if (board<>i) then sprint('@MLowest accessible message base.') + else lastcommandovr:=TRUE; + end; + 'L':mbaselist; + else + begin + changeboard(value(mstr)); + if pos(';',mstr)>0 then begin + s:=copy(mstr,pos(';',mstr)+1,length(mstr)); + curmenu:=systat.menupath+s+'.mnu'; + newmenutoload:=TRUE; + done:=TRUE; + end; + lastcommandovr:=TRUE; + end; + end + else begin + if (novice in thisuser.ac) then mbaselist; + nl; + s:='?'; + repeat + sprompt('^7Change message base (^3?^7=^3List^7) : ^3'); + input(s,3); i:=ccboards[0][value(s)]; + if s='?' then begin mbaselist; nl; end else + if (i>=1) and (i<=numboards) and (i<>board) then + changeboard(i); + until (s<>'?') or (hangup); + lastcommandovr:=TRUE; + end; +end; + +procedure readamsg; +var filv:text; + s:astr; + i,j:integer; +begin + nl; + assign(filv,systat.afilepath+'auto.msg'); + {$I-} reset(filv); {$I+} + nofile:=(ioresult<>0); + j:=0; + if (nofile) then sprint(#3#0+'No AutoMessage available.') + else begin + readln(filv,s); + case s[1] of + '@':if (aacs(systat.anonpubread)) then + s:=copy(s,2,length(s))+' (Posted Anonymously)' + else s:='Anonymous'; + '!':if (cso) then s:=copy(s,2,length(s))+' (Posted Anonymously)' + else s:='Anonymous'; + end; + sprint(fstring.automsgt+s); + repeat + readln(filv,s); + if lenn(s)>j then j:=lenn(s); + until (eof(filv)); + if (j>=thisuser.linelen) then j:=thisuser.linelen-1; + reset(filv); readln(filv,s); + cl(0); + if ((not okansi) or (fstring.autom=#32)) then nl + else for i:=1 to j do outkey(fstring.autom); + nl; + repeat + readln(filv,s); + sprint(#3#3+s); + until eof(filv); + cl(0); + if ((not okansi) or (fstring.autom=#32)) then nl + else for i:=1 to j do outkey(fstring.autom); + nl; + close(filv); + end; +end; + +procedure wamsg; +var filvar:text; + i,j:integer; + am:array[1..30] of astr; + n:astr; + c:char; + abort,next:boolean; +begin + if (ramsg in thisuser.ac) then + print('You are restricted from writing automessages.') + else begin + abort:=FALSE; + nl; + if mso then begin + print('Enter up to 30 lines, "." alone to end.'); + nl; + i:=0; + repeat + inc(i); + cl(3); inputwc(am[i],79); + until ((am[i]='.') or (i=30) or (hangup)); + if (am[i]='.') then dec(i); + j:=i; + end else begin + print('Enter three lines:'); + nl; + for i:=1 to 3 do begin cl(3); inputwc(am[i],79); end; + j:=3; + end; + nl; + if (j<>0) then begin + repeat + abort:=FALSE; + nl; + for i:=1 to j do sprint(#3#3+am[i]); + nl; + sprompt(#3#7+'Is this alright? [R]elist (Y/N) [Y] : '); + onekcr:=FALSE; onekda:=FALSE; onek(c,'NYR '^M); cl(3); + case c of + 'R':print('Relist'); + 'N':print('No'); + else + print('Yes'); + end; + until (c<>'R') or (hangup); + if (c<>'N') then begin + n:=nam; + if (aacs(systat.anonpubpost)) then + if pynq('Post Anonymously? ') then + if (realsl=255) then n:='!'+n else n:='@'+n; + + assign(filvar,systat.afilepath+'auto.msg'); + {$I-} reset(filvar); {$I+} + if (ioresult<>0) then assign(filvar,systat.afilepath+'auto.msg'); + rewrite(filvar); + writeln(filvar,n); + for i:=1 to j do writeln(filvar,am[i]); + close(filvar); + + nl; + print('Auto-message saved.'); + sysoplog('Changed Auto-message to:'); + for i:=1 to j do sysoplog(#3#3+am[i]); + end else + print('Nothing saved.'); + end else + print('Nothing saved.'); + end; +end; + +procedure replyamsg; +var autof:text; +begin + nl; + nofile:=FALSE; + assign(autof,systat.afilepath+'auto.msg'); + {$I-} reset(autof); {$I+} + if (ioresult<>0) then print('Nothing to reply to.') + else begin + irt:='Your auto-message'; + readln(autof,lastname); + close(autof); + if (lastname[1]='@') then + if (not aacs(systat.anonprivread)) then lastname:=''; + if (lastname[1]='!') and (so) then lastname:=''; + if (lastname='') then print('Can''t reply now.') else autoreply; + end; +end; + +procedure mbasestats; +var s:astr; + abort,next:boolean; + + procedure dd(var abort,next:boolean; s1,s2:astr; b:boolean); + begin + s1:=#3#3+s1+#3#5+' '; + if (b) then printacr(s1+s2,abort,next) + else printacr(s1+'None.',abort,next); + end; + +begin + abort:=FALSE; next:=FALSE; + nl; + loadboard(board); + with memboard do begin + s:=#3#3+'Statistics on "'+#3#5+name+' #'+cstr(ccboards[1][board])+#3#3+'"'; + printacr(s,abort,next); + nl; + dd(abort,next,'Base password ........ :','"'+password+'"',(password<>'')); + dd(abort,next,'Max messages ......... :',cstr(maxmsgs),(maxmsgs<>0)); + case anonymous of + atno :s:='None allowed'; + atyes :s:='Anonymous posts allowed'; + atforced :s:='All posts forced anonymous'; + atdearabby:s:='Dear Abby base'; + atanyname :s:='Any Name Goes'; + end; + dd(abort,next,'Anonymous type ....... :',s,TRUE); + if (fso) then begin + nl; + dd(abort,next,'ACS .................. :',acs,TRUE); + dd(abort,next,'Post ACS ............. :',postacs,TRUE); + dd(abort,next,'MCI ACS .............. :',mciacs,TRUE); + nl; + dd(abort,next,'Filename ...... :','"'+filename+'.BRD"',TRUE); + dd(abort,next,'Message path .. :','"'+msgpath+'"',(mbtype<>0)); + end; + end; +end; + +end. diff --git a/makeinit.bat b/makeinit.bat new file mode 100644 index 0000000..1d66b07 --- /dev/null +++ b/makeinit.bat @@ -0,0 +1,11 @@ +@Echo Off +Cls +Tpc Init.Pas /L /M +Echo. +If Errorlevel 1 Goto Failed +Echo Compile Successful +Goto Stop +:Failed +Echo Compile Failed! +:Stop +Echo. diff --git a/makemabs.bat b/makemabs.bat new file mode 100644 index 0000000..9beed63 --- /dev/null +++ b/makemabs.bat @@ -0,0 +1,18 @@ +@Echo Off +Cls +If "%1"=="" Goto Normal +Tpc Mabs.Pas /L /M /DAS%1 +Goto Cont +:Normal +Tpc Mabs.Pas /L /M +:Cont +Echo. +If Errorlevel 1 Goto Failed +Echo Compile Successful +If "%1"=="" Goto Stop +Rename Mabs.Exe Mabs%1.Exe +Goto Stop +:Failed +Echo Compile Failed! +:Stop +Echo. diff --git a/makestd.bat b/makestd.bat new file mode 100644 index 0000000..089cdf8 --- /dev/null +++ b/makestd.bat @@ -0,0 +1,16 @@ +@Echo Off +Cls +Cbbs Lcbbs.Pas +Ds Dtne +Echo. +Tpc Bbs.Pas /M /L +If Errorlevel 1 Goto Failed +Mabs 0 +Echo. +Echo Compile Successful +Goto Stop +:Failed +Echo. +Echo Compile Failed! +:Stop +Echo. diff --git a/maketerm.bat b/maketerm.bat new file mode 100644 index 0000000..b15ec81 --- /dev/null +++ b/maketerm.bat @@ -0,0 +1,11 @@ +@Echo Off +Cls +Tpc Miniterm.Pas /L /M +Echo. +If Errorlevel 1 Goto Failed +Echo Compile Successful +Goto Stop +:Failed +Echo Compile Failed! +:Stop +Echo. diff --git a/makezip.bat b/makezip.bat new file mode 100644 index 0000000..48c01bd --- /dev/null +++ b/makezip.bat @@ -0,0 +1,6 @@ +@Echo Off +Cls +Ds Ne +If Exist C:\Source.Zip Del C:\Source.Zip +Pkzip -A C:\Source Make*.Bat *.Obj *.Pas +Echo. diff --git a/mdek.pas b/mdek.pas new file mode 100644 index 0000000..c4bfeb5 --- /dev/null +++ b/mdek.pas @@ -0,0 +1,68 @@ +{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-} +unit mdek; + +interface + + +{rcg11172000 no overlay under Linux.} +{uses overlay;} + + +function encrypt(os:string; c1,c2,c3,c4,c5,c6:byte):string; +function decrypt(os:string; c1,c2,c3,c4,c5,c6:byte):string; + +implementation + +function encrypt(os:string; c1,c2,c3,c4,c5,c6:byte):string; +var ns:string; + codes:array[1..6] of byte; + c,d,i,j,k,l:integer; +begin + for i:=1 to 6 do + case i of 1:codes[i]:=c1; 2:codes[i]:=c2; 3:codes[i]:=c3; + 4:codes[i]:=c4; 5:codes[i]:=c5; 6:codes[i]:=c6; end; + j:=0; k:=1; l:=1; + for i:=1 to length(os) do begin + inc(j); + if (j>6) then begin + dec(k); j:=1; + if (k<1) then begin + dec(l); k:=6; + if (l<1) then begin + j:=1; k:=6; l:=6; + end; + end; + end; + d:=codes[j]+codes[k]+codes[l]; + os[i]:=chr((ord(os[i])+d) mod 256); + end; + encrypt:=os; +end; + +function decrypt(os:string; c1,c2,c3,c4,c5,c6:byte):string; +var ns:string; + codes:array[1..6] of byte; + c,d,i,j,k,l:integer; +begin + for i:=1 to 6 do + case i of 1:codes[i]:=c1; 2:codes[i]:=c2; 3:codes[i]:=c3; + 4:codes[i]:=c4; 5:codes[i]:=c5; 6:codes[i]:=c6; end; + j:=0; k:=1; l:=1; + for i:=1 to length(os) do begin + inc(j); + if (j>6) then begin + dec(k); j:=1; + if (k<1) then begin + dec(l); k:=6; + if (l<1) then begin + j:=1; k:=6; l:=6; + end; + end; + end; + d:=codes[j]+codes[k]+codes[l]; + os[i]:=chr((1024+(ord(os[i])-d)) mod 256); + end; + decrypt:=os; +end; + +end. diff --git a/menus.pas b/menus.pas new file mode 100644 index 0000000..f082aba --- /dev/null +++ b/menus.pas @@ -0,0 +1,555 @@ +{***************************************************************************** + * * + * Menus.Pas - * + * Menu Command Execution Routines. * + * * + * Modification History * + * ==================== * + * 08/20/91 - 1.00 - E?O - Original Version * + * * + *****************************************************************************} +{$A+,B+,D-,E+,F+,I+,L+,N-,O-,R-,S+,V-} +Unit Menus; + +Interface + +Uses + + {rcg11172000 no overlay under Linux.} + {Overlay,} + + Crt, Dos, InitP, Sysop1, Sysop2, Sysop3, + Sysop4, Sysop5, Sysop6, Sysop7, Sysop8, Sysop9, Sysop10, + Sysop11, Mail0, Mail1, Mail2, Mail3, Mail4, Mail5, + Mail6, Mail9, File0, File1, File2, File3, File4, + File5, File6, File7, File8, File9, File10, File11, + File12, File13, File14, Archive1, Archive2, Archive3, Misc1, + Misc2, Misc3, Misc4, MiscX, CUser, Doors, Menus2, + Menus3, Menus4, MyIO, Common; + +Procedure readin2; +Procedure mainmenuhandle(var cmd:string); +Procedure fcmd(cmd:string; var i:integer; noc:integer; + var cmdexists,cmdnothid:boolean); +Procedure domenuexec(cmd:string; var newmenucmd:string); +Procedure domenucommand(var done:boolean; cmd:string; var newmenucmd:string); + +Implementation + +Procedure readin2; +var s:string; + nacc:boolean; +begin + readin; + nacc:=FALSE; + with menur do begin + if ((not aacs(acs)) or (password<>'')) then + begin + nacc:=TRUE; + if (password<>'') then + begin + nl; prt('Password: '); input(s,15); + if (s=password) then nacc:=FALSE; + end; + if (nacc) then + begin + nl; print('Access denied.'); pausescr; + print('Dropping back to fallback menu...'); + curmenu:=systat.menupath+fallback+'.mnu'; + readin; + end; + end; + if (not nacc) then + if (forcehelplevel<>0) then + chelplevel:=forcehelplevel + else + if (novice in thisuser.ac) then chelplevel:=2 else chelplevel:=1; + end; +end; + +procedure checkforcelevel; +begin + if (chelplevel'') then + if (copy(buf,1,1)='`') then + begin + buf:=copy(buf,2,length(buf)-1); + i:=pos('`',buf); + if (i<>0) then + begin + s:=allcaps(copy(buf,1,i-1)); buf:=copy(buf,i+1,length(buf)-i); + nl; exit; + end; + end; + + shas0:='?|'; shas1:=''; + has0:=FALSE; has1:=FALSE; has2:=FALSE; + + { find out what kind of 0:"x", 1:"/x", and 2:"//xxxxxxxx..." commands + are in this menu. } + + for i:=1 to noc do + if (aacs(cmdr[i].acs)) then + if (cmdr[i].ckeys[0]=#1) then + begin + has0:=TRUE; shas0:=shas0+cmdr[i].ckeys; + end else + if ((cmdr[i].ckeys[1]='/') and (cmdr[i].ckeys[0]=#2)) then + begin + has1:=TRUE; shas1:=shas1+cmdr[i].ckeys[2]; + end else + has2:=TRUE; + + oldco:=curco; + + gotcmd:=FALSE; ss:=''; + if (not (onekey in thisuser.ac)) then + input(s,60) + else begin + repeat + getkey(c); c:=upcase(c); + oss:=ss; + if (ss='') then begin + if (c=#13) then gotcmd:=TRUE; + if ((c='/') and ((has1) or (has2) or (thisuser.sl=255))) then ss:='/'; + if ((c='=') and (cso)) then begin gotcmd:=TRUE; ss:=c; end; + if (((fqarea) or (mqarea)) and (c in ['0'..'9'])) then + ss:=c + else + if (pos(c,shas0)<>0) then begin gotcmd:=TRUE; ss:=c; end; + end else + if (ss='/') then begin + if (c=^H) then ss:=''; + if ((c='/') and ((has2) or (thisuser.sl=255))) then ss:=ss+'/'; + if ((pos(c,shas1)<>0) and (has1)) then + begin gotcmd:=TRUE; ss:=ss+c; end; + end else + if (copy(ss,1,2)='//') then begin + if (c=#13) then + gotcmd:=TRUE + else + if (c=^H) then + ss:=copy(ss,1,length(ss)-1) + else + if (c=^X) then begin + for i:=1 to length(ss)-2 do + prompt(^H' '^H); + ss:='//'; + oss:=ss; + end else + if ((length(ss)<62) and (c>=#32) and (c<=#127)) then + ss:=ss+c; + end else + if ((length(ss)>=1) and (ss[1] in ['0'..'9']) and + ((fqarea) or (mqarea))) then begin + if (c=^H) then ss:=copy(ss,1,length(ss)-1); + if (c=#13) then gotcmd:=TRUE; + if (c in ['0'..'9']) then begin + ss:=ss+c; + if (length(ss)=3) then gotcmd:=TRUE; + end; + end; + + if ((length(ss)=1) and (length(oss)=2)) then setc(oldco); + if (oss<>ss) then begin + if (length(ss)>length(oss)) then prompt(copy(ss,length(ss),1)); + if (length(ss)0) then {* "command macros" *} + if (copy(s,1,2)<>'\\') then begin + if (onekey in thisuser.ac) then begin + s1:=copy(s,2,length(s)-1); + if (copy(s1,1,1)='/') then s:=copy(s1,1,2) else s:=copy(s1,1,1); + s1:=copy(s1,length(s)+1,length(s1)-length(s)); + end else begin + s1:=copy(s,pos(';',s)+1,length(s)-pos(';',s)); + s:=copy(s,1,pos(';',s)-1); + end; + while (pos(';',s1)<>0) do s1[pos(';',s1)]:=^M; + dm(' '+s1,c); + end; +end; + +procedure mainmenuhandle(var cmd:string); +var newarea:integer; + wantshow:boolean; +begin + tleft; + macok:=TRUE; + + checkforcelevel; + + if ((forcepause in menur.menuflags) and (chelplevel>1) and (lastcommandgood)) + then pausescr; + lastcommandgood:=FALSE; + showthismenu; + + if (not (nomenuprompt in menur.menuflags)) then begin + nl; + if (autotime in menur.menuflags) then + sprint(#3#3+'[