From c97d23ec6b95706cd299d05161e9da02b0c00745 Mon Sep 17 00:00:00 2001 From: "Ryan C. Gordon" Date: Sat, 18 Nov 2000 00:33:00 +0000 Subject: [PATCH] Initial revision --- CHANGELOG | 22 + Makefile | 112 ++ a.bat | 3 + amake.bat | 4 + archive1.pas | 555 ++++++++++ archive2.pas | 684 ++++++++++++ archive3.pas | 196 ++++ ascii.inc | 26 + asyint.map | 38 + bb.pas | 389 +++++++ bbs.pas | 332 ++++++ bbs.~pa | 350 ++++++ boarde.msg | 25 + boarder.msg | 1 + brec17a2.pas | 233 ++++ c.bat | 2 + c.~ba | 2 + cbbs.pas | 110 ++ cc.bat | 14 + change.me | 168 +++ coconfig.pas | 800 ++++++++++++++ common.pas | 2965 ++++++++++++++++++++++++++++++++++++++++++++++++++ common1.pas | 829 ++++++++++++++ common2.pas | 1123 +++++++++++++++++++ common3.pas | 274 +++++ conv17a.pas | 969 +++++++++++++++++ conv17a9.pas | 860 +++++++++++++++ conv18a.pas | 1660 ++++++++++++++++++++++++++++ cuser.pas | 794 ++++++++++++++ cx.pas | 8 + doors.pas | 394 +++++++ edit2.txt | 14 + editpro.txt | 44 + execbat.pas | 151 +++ execswap.pas | 184 ++++ fastchr.asm | 240 ++++ file0.pas | 389 +++++++ file1.pas | 1035 ++++++++++++++++++ file10.pas | 549 ++++++++++ file11.pas | 544 +++++++++ file12.pas | 516 +++++++++ file13.pas | 317 ++++++ file14.pas | 118 ++ file2.pas | 124 +++ file3.pas | 191 ++++ file4.pas | 578 ++++++++++ file5.pas | 770 +++++++++++++ file6.pas | 557 ++++++++++ file7.pas | 180 +++ file8.pas | 338 ++++++ file9.pas | 348 ++++++ file_id.diz | 5 + findit.pas | 34 + func.pas | 92 ++ fvtype.pas | 141 +++ gloasync.inc | 141 +++ globtype.inc | 17 + go.bat | 6 + go.~ba | 3 + ifl.inc | 119 ++ ifl.pas | 481 ++++++++ init.pas | 1311 ++++++++++++++++++++++ init16d3.pas | 824 ++++++++++++++ init16e1.pas | 958 ++++++++++++++++ initp.pas | 568 ++++++++++ ints.inc | 15 + lamer.pas | 5 + lcbbs.pas | 1 + logon1.pas | 582 ++++++++++ logon2.pas | 495 +++++++++ logon2.~pa | 492 +++++++++ mabs.pas | 268 +++++ mail0.pas | 403 +++++++ mail1.pas | 974 +++++++++++++++++ mail2.pas | 390 +++++++ mail3.pas | 244 +++++ mail4.pas | 474 ++++++++ mail5.pas | 728 +++++++++++++ mail6.pas | 372 +++++++ mail9.pas | 340 ++++++ makeinit.bat | 11 + makemabs.bat | 18 + makestd.bat | 16 + maketerm.bat | 11 + makezip.bat | 6 + mdek.pas | 68 ++ menus.pas | 555 ++++++++++ menus2.pas | 382 +++++++ menus3.pas | 84 ++ menus4.pas | 67 ++ miniterm.pas | 1266 +++++++++++++++++++++ misc1.pas | 402 +++++++ misc2.pas | 619 +++++++++++ misc3.pas | 201 ++++ misc4.pas | 345 ++++++ miscx.pas | 324 ++++++ mmodem.pas | 179 +++ msgpack.pas | 133 +++ mtest.pas | 26 + myio.pas | 513 +++++++++ newcom.pas | 550 ++++++++++ newusers.pas | 272 +++++ oblit.pas | 84 ++ pib1.pas | 294 +++++ pib2.pas | 58 + pibo.pas | 1144 +++++++++++++++++++ protocol.dat | Bin 0 -> 6946 bytes quote.txt | 11 + rcc17a.pas | 525 +++++++++ rcc18a.pas | 601 ++++++++++ rec17a.pas | 514 +++++++++ rec18a.pas | 601 ++++++++++ rec19.pas | 694 ++++++++++++ rec20.pas | 726 ++++++++++++ rec25.pas | 714 ++++++++++++ recc.pas | 164 +++ reccold.pas | 167 +++ sepmsgs.pas | 271 +++++ sources | 135 +++ spdate.pas | 29 + strct24d.pas | 346 ++++++ stubs.pas | 48 + sysop1.pas | 462 ++++++++ sysop10.pas | 132 +++ sysop11.pas | 199 ++++ sysop2.pas | 90 ++ sysop21.pas | 87 ++ sysop2a.pas | 260 +++++ sysop2b.pas | 245 +++++ sysop2c.pas | 91 ++ sysop2d.pas | 109 ++ sysop2e.pas | 172 +++ sysop2f.pas | 95 ++ sysop2fa.pas | 207 ++++ sysop2g.pas | 198 ++++ sysop2h.pas | 60 + sysop2i.pas | 109 ++ sysop2s.pas | 219 ++++ sysop2z.pas | 54 + sysop3.pas | 1133 +++++++++++++++++++ sysop4.pas | 467 ++++++++ sysop5.pas | 546 ++++++++++ sysop6.pas | 307 ++++++ sysop7.pas | 526 +++++++++ sysop7m.pas | 127 +++ sysop8.pas | 749 +++++++++++++ sysop9.pas | 573 ++++++++++ t2t.pas | 1283 ++++++++++++++++++++++ ta2z.pas | 585 ++++++++++ tackroom.bbs | 0 tagr24b.pas | 154 +++ tagr24d.pas | 204 ++++ tagrec24.pas | 126 +++ test.pas | 45 + thedraw.pck | Bin 0 -> 650 bytes timejunk.pas | 211 ++++ tmpcom.pas | 799 ++++++++++++++ tmpcommm.pas | 318 ++++++ tmu.pas | 104 ++ tosysop.ltr | Bin 0 -> 2430 bytes tpage.pas | 42 + tpansi.pas | 799 ++++++++++++++ upacs.pas | 6 + wcat20.pas | 64 ++ wfcmenu.pas | 1051 ++++++++++++++++++ white.txt | 1 + windows.pas | 142 +++ yellow.txt | 1 + zzalpha.bat | 11 + zzbeta.bat | 21 + zzstand.bat | 21 + 171 files changed, 57991 insertions(+) create mode 100644 CHANGELOG create mode 100644 Makefile create mode 100644 a.bat create mode 100644 amake.bat create mode 100644 archive1.pas create mode 100644 archive2.pas create mode 100644 archive3.pas create mode 100644 ascii.inc create mode 100644 asyint.map create mode 100644 bb.pas create mode 100644 bbs.pas create mode 100644 bbs.~pa create mode 100644 boarde.msg create mode 100644 boarder.msg create mode 100644 brec17a2.pas create mode 100644 c.bat create mode 100644 c.~ba create mode 100644 cbbs.pas create mode 100644 cc.bat create mode 100644 change.me create mode 100644 coconfig.pas create mode 100644 common.pas create mode 100644 common1.pas create mode 100644 common2.pas create mode 100644 common3.pas create mode 100644 conv17a.pas create mode 100644 conv17a9.pas create mode 100644 conv18a.pas create mode 100644 cuser.pas create mode 100644 cx.pas create mode 100644 doors.pas create mode 100644 edit2.txt create mode 100644 editpro.txt create mode 100644 execbat.pas create mode 100644 execswap.pas create mode 100644 fastchr.asm create mode 100644 file0.pas create mode 100644 file1.pas create mode 100644 file10.pas create mode 100644 file11.pas create mode 100644 file12.pas create mode 100644 file13.pas create mode 100644 file14.pas create mode 100644 file2.pas create mode 100644 file3.pas create mode 100644 file4.pas create mode 100644 file5.pas create mode 100644 file6.pas create mode 100644 file7.pas create mode 100644 file8.pas create mode 100644 file9.pas create mode 100644 file_id.diz create mode 100644 findit.pas create mode 100644 func.pas create mode 100644 fvtype.pas create mode 100644 gloasync.inc create mode 100644 globtype.inc create mode 100644 go.bat create mode 100644 go.~ba create mode 100644 ifl.inc create mode 100644 ifl.pas create mode 100644 init.pas create mode 100644 init16d3.pas create mode 100644 init16e1.pas create mode 100644 initp.pas create mode 100644 ints.inc create mode 100644 lamer.pas create mode 100644 lcbbs.pas create mode 100644 logon1.pas create mode 100644 logon2.pas create mode 100644 logon2.~pa create mode 100644 mabs.pas create mode 100644 mail0.pas create mode 100644 mail1.pas create mode 100644 mail2.pas create mode 100644 mail3.pas create mode 100644 mail4.pas create mode 100644 mail5.pas create mode 100644 mail6.pas create mode 100644 mail9.pas create mode 100644 makeinit.bat create mode 100644 makemabs.bat create mode 100644 makestd.bat create mode 100644 maketerm.bat create mode 100644 makezip.bat create mode 100644 mdek.pas create mode 100644 menus.pas create mode 100644 menus2.pas create mode 100644 menus3.pas create mode 100644 menus4.pas create mode 100644 miniterm.pas create mode 100644 misc1.pas create mode 100644 misc2.pas create mode 100644 misc3.pas create mode 100644 misc4.pas create mode 100644 miscx.pas create mode 100644 mmodem.pas create mode 100644 msgpack.pas create mode 100644 mtest.pas create mode 100644 myio.pas create mode 100644 newcom.pas create mode 100644 newusers.pas create mode 100644 oblit.pas create mode 100644 pib1.pas create mode 100644 pib2.pas create mode 100644 pibo.pas create mode 100644 protocol.dat create mode 100644 quote.txt create mode 100644 rcc17a.pas create mode 100644 rcc18a.pas create mode 100644 rec17a.pas create mode 100644 rec18a.pas create mode 100644 rec19.pas create mode 100644 rec20.pas create mode 100644 rec25.pas create mode 100644 recc.pas create mode 100644 reccold.pas create mode 100644 sepmsgs.pas create mode 100644 sources create mode 100644 spdate.pas create mode 100644 strct24d.pas create mode 100644 stubs.pas create mode 100644 sysop1.pas create mode 100644 sysop10.pas create mode 100644 sysop11.pas create mode 100644 sysop2.pas create mode 100644 sysop21.pas create mode 100644 sysop2a.pas create mode 100644 sysop2b.pas create mode 100644 sysop2c.pas create mode 100644 sysop2d.pas create mode 100644 sysop2e.pas create mode 100644 sysop2f.pas create mode 100644 sysop2fa.pas create mode 100644 sysop2g.pas create mode 100644 sysop2h.pas create mode 100644 sysop2i.pas create mode 100644 sysop2s.pas create mode 100644 sysop2z.pas create mode 100644 sysop3.pas create mode 100644 sysop4.pas create mode 100644 sysop5.pas create mode 100644 sysop6.pas create mode 100644 sysop7.pas create mode 100644 sysop7m.pas create mode 100644 sysop8.pas create mode 100644 sysop9.pas create mode 100644 t2t.pas create mode 100644 ta2z.pas create mode 100644 tackroom.bbs create mode 100644 tagr24b.pas create mode 100644 tagr24d.pas create mode 100644 tagrec24.pas create mode 100644 test.pas create mode 100644 thedraw.pck create mode 100644 timejunk.pas create mode 100644 tmpcom.pas create mode 100644 tmpcommm.pas create mode 100644 tmu.pas create mode 100644 tosysop.ltr create mode 100644 tpage.pas create mode 100644 tpansi.pas create mode 100644 upacs.pas create mode 100644 wcat20.pas create mode 100644 wfcmenu.pas create mode 100644 white.txt create mode 100644 windows.pas create mode 100644 yellow.txt create mode 100644 zzalpha.bat create mode 100644 zzbeta.bat create mode 100644 zzstand.bat 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+'[