Initial revision
This commit is contained in:
Ryan C. Gordon
parent
017fe3965f
commit
c97d23ec6b
|
|
@ -0,0 +1,22 @@
|
|||
|
||||
|
||||
2000-11-17 Ryan C. Gordon <icculus@lokigames.com>
|
||||
|
||||
* 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 ...
|
||||
|
||||
|
||||
|
|
@ -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 ...
|
||||
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
@echo off
|
||||
copy mabs.pas mabs%1.pas
|
||||
call c mabs%1 /DAS%1
|
||||
del mabs%1.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<maxarcs+1) do
|
||||
inc(atype);
|
||||
if (atype=maxarcs+1) or (systat.filearcinfo[atype].ext='') or
|
||||
(not systat.filearcinfo[atype].active) then atype:=0;
|
||||
arctype:=atype;
|
||||
end;
|
||||
|
||||
procedure listarctypes;
|
||||
var i,j:integer;
|
||||
begin
|
||||
i:=1; j:=0;
|
||||
while (systat.filearcinfo[i].ext<>'') and (i<maxarcs) do begin
|
||||
if (systat.filearcinfo[i].active) then begin
|
||||
inc(j);
|
||||
if (j=1) then prompt('Available archive formats: ') else prompt(',');
|
||||
prompt(systat.filearcinfo[i].ext);
|
||||
end;
|
||||
inc(i);
|
||||
end;
|
||||
if (j=0) then prompt('No archive formats available.');
|
||||
nl;
|
||||
end;
|
||||
|
||||
procedure invarc;
|
||||
begin
|
||||
print('Unsupported archive format.');
|
||||
nl;
|
||||
listarctypes;
|
||||
nl;
|
||||
end;
|
||||
|
||||
procedure extracttotemp;
|
||||
var fi:file of byte;
|
||||
f:ulfrec;
|
||||
s,fn,ps,ns,es:astr;
|
||||
numfiles,tsiz,lng:longint;
|
||||
pl,rn,atype:integer;
|
||||
c:char;
|
||||
abort,next,done,ok,toextract,tocopy,didsomething,nospace:boolean;
|
||||
begin
|
||||
didsomething:=FALSE;
|
||||
nl;
|
||||
print('Extract to temporary directory -');
|
||||
nl;
|
||||
prompt('Already in TEMP: ');
|
||||
numfiles:=0; tsiz:=0;
|
||||
findfirst(systat.temppath+'3\*.*',anyfile-dos.directory,dirinfo);
|
||||
found:=(doserror=0);
|
||||
while (found) do begin
|
||||
inc(tsiz,dirinfo.size);
|
||||
inc(numfiles);
|
||||
findnext(dirinfo);
|
||||
found:=(doserror=0);
|
||||
end;
|
||||
if (numfiles=0) then print('Nothing.')
|
||||
else print(cstrl(numfiles)+' files totalling '+cstrl(tsiz)+' bytes.');
|
||||
|
||||
if (not fso) then begin
|
||||
print('The limit is '+cstrl(systat.maxintemp)+'k bytes.');
|
||||
lng:=systat.maxintemp; lng:=lng*1024;
|
||||
if (tsiz>lng) 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 (<CR>=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.
|
||||
|
|
@ -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) do begin
|
||||
seek(ulff,rn); read(ulff,f);
|
||||
inc(numfl);
|
||||
fl[numfl]:=f.filename;
|
||||
nrecno(fn,pl,rn);
|
||||
end;
|
||||
if (numfl=oldnumfl) then print('No matching files.');
|
||||
if (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) do begin
|
||||
inc(numfl);
|
||||
fl[numfl]:=fexpand(dstr+dirinfo.name);
|
||||
findnext(dirinfo);
|
||||
end;
|
||||
if (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 - <CR> 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 (i<numfl) do begin
|
||||
inc(i); inc(j);
|
||||
s2:=sqoutsp(fl[i]);
|
||||
if (not isul(s2)) then
|
||||
s2:=memuboard.dlpath+s2;
|
||||
os1:=s1;
|
||||
s1:=s1+' '+s2;
|
||||
end;
|
||||
if (length(s1)>maxdoschrline) 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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 *)
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 y<lodrv then y:=chr(ord(hidrv)+3);
|
||||
if y<>oy 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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
ﾍﾍﾋﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾋﾍﾍﾋﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾋﾍﾍﾋﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍﾍ=
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
==:==============:==:==========:==:========================================
|
||||
|
|
@ -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;
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
c:\tp\tpc /$G+ /B /ic:\t\ /uc:\t\ /uc:\tp /m /l bbs.pas %2 %3 %4 %5 %6
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
c:\tp\tpc /$G+ /ic:\t\ /uc:\t\ /uc:\tp /m /l bbs.pas %2 %3 %4 %5 %6
|
||||
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
|
@ -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.');
|
||||
|
|
@ -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)<len) do s:=s+' ';
|
||||
mln:=s;
|
||||
end;
|
||||
|
||||
function getscreen(x,y,z:byte):byte;
|
||||
begin
|
||||
{rcg11172000 doesn't fly under Linux.}
|
||||
{getscreen:=mem[vidseg:(160*(y-1)+2*(x-1))+z];}
|
||||
writeln('STUB: coconfig.pas; getscreen()...');
|
||||
getscreen:=0;
|
||||
end;
|
||||
|
||||
procedure putscreen(x,y,c,col:byte);
|
||||
begin
|
||||
{rcg11172000 doesn't fly under Linux.}
|
||||
{
|
||||
mem[vidseg:(160*(y-1)+2*(x-1))]:=c;
|
||||
mem[vidseg:(160*(y-1)+2*(x-1))+1]:=col;
|
||||
}
|
||||
writeln('STUB: coconfig.pas; putscreen()...');
|
||||
end;
|
||||
|
||||
procedure updateeditingline;
|
||||
begin
|
||||
textset(0,7); gotoxy(34,13);
|
||||
if (cfilter_name<>'') 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.
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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 (maxulb<maxuboards) then begin
|
||||
ccuboards[1][maxulb+1]:=j;
|
||||
ccuboards[0][j]:=maxulb+1;
|
||||
end;
|
||||
|
||||
seek(bf,0); i:=1; j:=1; done:=FALSE;
|
||||
while ((not done) and (i<=maxboards)) do begin
|
||||
{$I-} read(bf,memboard); {$I+}
|
||||
done:=(ioresult<>0);
|
||||
|
||||
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 (numboards<maxboards) then begin
|
||||
ccboards[1][numboards+1]:=j;
|
||||
ccboards[0][j]:=maxboards+1;
|
||||
end;
|
||||
|
||||
if (not bfo) then close(bf);
|
||||
if (not ulfo) then close(ulf);
|
||||
|
||||
memuboard:=savuboard; readuboard:=savreaduboard;
|
||||
memboard:=savboard; readboard:=savreadboard;
|
||||
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure cline(var s:string; dd:string);
|
||||
var i,u:integer;
|
||||
sx,sy,sz:byte;
|
||||
b,savwindowon:boolean;
|
||||
begin
|
||||
sx:=wherex; sy:=wherey; sz:=textattr;
|
||||
savwindowon:=cwindowon;
|
||||
|
||||
if (not cwindowon) then begin
|
||||
cwindowon:=TRUE;
|
||||
schangewindow(TRUE,1);
|
||||
end;
|
||||
commandline('');
|
||||
window(1,1,80,25);
|
||||
|
||||
if (systat.istopwindow) then
|
||||
gotoxy(2,getwindysize(systat.curwindow))
|
||||
else
|
||||
gotoxy(2,26-getwindysize(systat.curwindow));
|
||||
tc(15); textbackground(1); write(dd+' ');
|
||||
tc(14); local_inputl(s,78-wherex);
|
||||
|
||||
inuserwindow;
|
||||
gotoxy(sx,sy); textattr:=sz;
|
||||
if (not savwindowon) then sclearwindow;
|
||||
end;
|
||||
|
||||
procedure pausescr;
|
||||
var ddt,dt1,dt2:datetimerec;
|
||||
i,x:integer;
|
||||
s:string[3];
|
||||
c:char;
|
||||
bb:byte;
|
||||
begin
|
||||
nosound;
|
||||
bb:=curco;
|
||||
cl(8);
|
||||
x:=lenn(fstring.pause); sprompt(fstring.pause); lil:=0;
|
||||
|
||||
getkey(c);
|
||||
(*
|
||||
getdatetime(dt1);
|
||||
repeat
|
||||
checkhangup; c:=inkey;
|
||||
getdatetime(dt2);
|
||||
timediff(ddt,dt1,dt2);
|
||||
if ((dt2r(ddt)>systat.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<filesize(zscanf)) then begin
|
||||
seek(zscanf,usernum); read(zscanf,zscanr);
|
||||
close(zscanf);
|
||||
exit;
|
||||
end;
|
||||
with zscanr do begin
|
||||
for i:=1 to maxboards do
|
||||
for j:=1 to 6 do mhiread[i][j]:=0;
|
||||
mzscan:=[]; fzscan:=[];
|
||||
for i:=1 to maxboards do mzscan:=mzscan+[i];
|
||||
for i:=0 to maxuboards do fzscan:=fzscan+[i];
|
||||
end;
|
||||
seek(zscanf,filesize(zscanf));
|
||||
repeat write(zscanf,zscanr) until (filesize(zscanf)>=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 (usernum<filesize(zscanf)) then begin
|
||||
seek(zscanf,usernum); write(zscanf,zscanr);
|
||||
close(zscanf);
|
||||
exit;
|
||||
end;
|
||||
close(zscanf);
|
||||
end;
|
||||
|
||||
procedure redrawforansi;
|
||||
begin
|
||||
if (dosansion) then begin dosansion:=FALSE; topscr; end;
|
||||
textattr:=7; curco:=7;
|
||||
if ((outcom) and (okansi)) then begin
|
||||
if (okavatar) then pr1(^V+^A+#7) else pr1(#27+'[0m');
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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 <CR> 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.
|
||||
|
|
@ -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 (<ESC> 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.
|
||||
|
|
@ -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 (<ESC> 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.
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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: <House number> <Street> [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<n) then begin
|
||||
user.computer:=ctyp[i];
|
||||
done1:=TRUE;
|
||||
end else
|
||||
if i=n then other:=TRUE;
|
||||
end;
|
||||
if (other) then begin
|
||||
if cexist then prt('Other computer type: ')
|
||||
else prt('Enter your computer type: ');
|
||||
if (how=3) then inputl(s,30) else inputcaps(s,30);
|
||||
if (s<>'') 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 <CR> 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.
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
uses dos;
|
||||
|
||||
{$I rec30}
|
||||
|
||||
begin
|
||||
writeln(sizeof(userrec));
|
||||
end.
|
||||
|
||||
|
|
@ -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.
|
||||
|
|
@ -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;
|
||||
|
|
@ -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;
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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+'<NV>';
|
||||
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<pl) and (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 r<s then r:=r+86400.0;
|
||||
if (r-s)>i 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.
|
||||
|
|
@ -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('<CR>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 (<CR>=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.
|
||||
|
|
@ -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)<lenn(s)) do s1:=s1+'-';
|
||||
if (fbnoratio in memuboard.fbstat) then s:=s+#3#5+' <No-Ratio>';
|
||||
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+' <No-Ratio>';
|
||||
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.
|
||||
|
|
@ -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.
|
||||
|
||||
|
|
@ -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);
|
||||
'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;
|
||||
|
||||
procedure figure2;
|
||||
begin
|
||||
case sortt of
|
||||
'B':if (isequ) then 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 (r1<r2) then begin
|
||||
seek(ulff,r1); read(ulff,f1);
|
||||
seek(ulff,r2); read(ulff,f2);
|
||||
end else begin
|
||||
seek(ulff,r2); read(ulff,f2);
|
||||
seek(ulff,r1); read(ulff,f1);
|
||||
end;
|
||||
|
||||
if (isascend) then islesser:=not islesser;
|
||||
if (islesser) then figure1 else figure2;
|
||||
greater:=b;
|
||||
end;
|
||||
|
||||
(* *
|
||||
* While I personally think labels are stupid as *@#((#@!#$, and they look *
|
||||
* like *#$@*, I kept them in for lack of a better idea! *
|
||||
*)
|
||||
procedure mainsort(pl:integer);
|
||||
label 10,20,30,40,50,60,70,80;
|
||||
const maxsortrec=2000; (* maximum size of directory which can be processed *)
|
||||
var hold,pass:array[1..maxsortrec] of integer;
|
||||
a,b,c,d,e,f,x:integer;
|
||||
begin
|
||||
a:=pl; b:=0; c:=0; d:=1; e:=1; f:=0;
|
||||
10:
|
||||
if (a-e<9) then goto 70;
|
||||
b:=e; c:=a;
|
||||
20:
|
||||
if (greater(TRUE,FALSE,b,c)) then begin
|
||||
switch(c,b);
|
||||
goto 60;
|
||||
end;
|
||||
30:
|
||||
dec(c);
|
||||
if (c>b) then goto 20;
|
||||
inc(c);
|
||||
40:
|
||||
inc(d);
|
||||
if (b-e<a-c) then begin
|
||||
hold[d]:=c; pass[d]:=a;
|
||||
a:=b;
|
||||
goto 10;
|
||||
end;
|
||||
hold[d]:=e; pass[d]:=b;
|
||||
e:=c;
|
||||
goto 10;
|
||||
50:
|
||||
if (greater(FALSE,FALSE,c,b)) then begin
|
||||
switch(c,b);
|
||||
goto 30;
|
||||
end;
|
||||
60:
|
||||
inc(b);
|
||||
if (c>b) 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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 <filename> 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)<w do s:='0'+s;
|
||||
mnz:=s;
|
||||
end;
|
||||
|
||||
function mnr(l:longint; w:integer):astr;
|
||||
begin
|
||||
mnr:=mrn(cstrl(l),w);
|
||||
end;
|
||||
|
||||
{*------------------------------------------------------------------------*}
|
||||
|
||||
procedure abend(var abort,next:boolean; message:string);
|
||||
begin
|
||||
{* abend - Display error message
|
||||
*}
|
||||
|
||||
nl;
|
||||
sprompt(#3#7+'** '+#3#5+message+#3#7+' **');
|
||||
nl;
|
||||
aborted:=TRUE;
|
||||
abort:=TRUE;
|
||||
next:=TRUE;
|
||||
end;
|
||||
|
||||
{*------------------------------------------------------------------------*}
|
||||
|
||||
procedure details(var abort,next:boolean);
|
||||
var i,month,day,year,hour,minute,typ:integer;
|
||||
ampm:char;
|
||||
ratio:longint;
|
||||
outp:string;
|
||||
begin
|
||||
{* details - Calculate and display details line.
|
||||
*}
|
||||
|
||||
typ:=out.typ;
|
||||
for i:=1 to length(out.filename) do
|
||||
out.filename[i]:=upcase(out.filename[i]);
|
||||
day:=out.date and $1f; {* day = bits 4-0 *}
|
||||
month:=(out.date shr 5) and $0f; {* month = bits 8-5 *}
|
||||
year:=((out.date shr 9) and $7f)+80; {* year = bits 15-9 *}
|
||||
minute:=(out.time shr 5) and $3f; {* minute = bits 10-5 *}
|
||||
hour:=(out.time shr 11) and $1f; {* hour = bits 15-11 *}
|
||||
|
||||
if (month>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.
|
||||
|
|
@ -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 (i<length(s)) do begin
|
||||
inc(i);
|
||||
if ((s[i]=' ') or (length(s)=i)) then begin
|
||||
if (length(s)=i) then inc(i);
|
||||
xword[k]:=copy(s,j,(i-j));
|
||||
j:=i+1;
|
||||
inc(k);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure minidos;
|
||||
var curdir,s,s1:astr;
|
||||
abort,next,done,restr,nocmd,nospace:boolean;
|
||||
|
||||
procedure versioninfo;
|
||||
begin
|
||||
nl;
|
||||
print('Telegard(R) Mini-DOS(R) Version '+ver);
|
||||
print(' (C)Copyright 1988,89,90 The Telegard Team');
|
||||
nl;
|
||||
end;
|
||||
|
||||
procedure docmd(cmd:astr);
|
||||
var fi:file of byte;
|
||||
f:file;
|
||||
ps,ns,es,op,np:astr;
|
||||
s1,s2,s3:astr;
|
||||
numfiles,tsiz:longint;
|
||||
retlevel,i,j:integer;
|
||||
b,ok,wasrestr:boolean;
|
||||
|
||||
function restr1:boolean;
|
||||
begin
|
||||
restr1:=restr;
|
||||
if (restr) then wasrestr:=TRUE;
|
||||
end;
|
||||
|
||||
begin
|
||||
wasrestr:=FALSE;
|
||||
abort:=FALSE; next:=FALSE; nocmd:=FALSE;
|
||||
for i:=1 to 9 do xword[i]:=allcaps(xword[i]);
|
||||
s:=xword[1];
|
||||
if ((pos('\',xword[2])<>0) 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+' <Old Archive-name> <New Archive-extension>"');
|
||||
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-name> 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-name> 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-otopp<perpage) and (topp<=pl) and
|
||||
(not abort) and (not hangup) do begin
|
||||
if (topp<=pl) then begin
|
||||
seek(ulff,topp); read(ulff,f);
|
||||
pbn(abort,next);
|
||||
pfn(topp,f,abort,next);
|
||||
end;
|
||||
inc(topp);
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
fiscan(pl); { loads memuboard }
|
||||
nl;
|
||||
sprint(#3#5+memuboard.name+#3#4+' - '+cstr(pl)+' files');
|
||||
if (pl=0) then exit;
|
||||
nl;
|
||||
prt('Start at (1-'+cstr(pl)+',Q=Quit) : '); inu(topp);
|
||||
if (badini) then topp:=1;
|
||||
if ((topp<1) or (topp>pl)) 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 <CR> 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.
|
||||
|
|
@ -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 ((n<numbatchfiles) and (not foundit)) do begin
|
||||
inc(n);
|
||||
if (allcaps(batch[n].fn)=allcaps(filestr)) then foundit:=TRUE;
|
||||
end;
|
||||
if (foundit) then begin
|
||||
if (wasok) then begin
|
||||
sysoplog(#3#5+'Batch downloaded "'+stripname(batch[n].fn)+'"');
|
||||
inc(tnfils);
|
||||
inc(tblks,batch[n].blks);
|
||||
inc(tpts,batch[n].pts);
|
||||
loaduboard(batch[n].section);
|
||||
if (not (fbnoratio in memuboard.fbstat)) then begin
|
||||
inc(tnfils1);
|
||||
inc(tblks1,batch[n].blks);
|
||||
inc(tpts1,batch[n].pts);
|
||||
end;
|
||||
addnacc(batch[n].section,batch[n].fn);
|
||||
delbatch(n);
|
||||
end else
|
||||
sysoplog(#3#7+'Tried batch download "'+stripname(batch[n].fn)+'"');
|
||||
end else
|
||||
sysoplog(#3#7+'*Batch downloaded unauthorized file? "'+filestr+'"');
|
||||
end;
|
||||
close(batfile);
|
||||
close(tfil);
|
||||
end;
|
||||
end;
|
||||
if (not readlog) then begin
|
||||
while (toxfer>0) 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 (toxfer<numbatchfiles)) do begin
|
||||
inc(toxfer); snfn:=nfn;
|
||||
bproline(nfn,batch[toxfer].fn);
|
||||
if (length(nfn)>protocol.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 (tnfils<tnfils1) then tnfils1:=tnfils;
|
||||
|
||||
s:='Download charges: ';
|
||||
if (tnfils1=0) then s:=s+'No' else s:=s+cstr(tnfils1);
|
||||
s:=s+' file'; if (tnfils1<>1) 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+' <No-Ratio>';
|
||||
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.
|
||||
|
|
@ -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 (timer<start_time) then start_time:=start_time-24*60*60;
|
||||
end;
|
||||
dok:=not abort;
|
||||
end;
|
||||
|
||||
procedure sendascii(fn:astr);
|
||||
var f:file of char;
|
||||
i:integer;
|
||||
c,c1:char;
|
||||
abort:boolean;
|
||||
|
||||
procedure ckey;
|
||||
begin
|
||||
checkhangup;
|
||||
while (not empty) and (not abort) and (not hangup) do begin
|
||||
if (hangup) then abort:=TRUE;
|
||||
c1:=inkey;
|
||||
if (c1=^X) or (c1=#27) or (c1=' ') then abort:=TRUE;
|
||||
if (c1=^S) then getkey(c1);
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
assign(f,fn);
|
||||
{$I-} reset(f); {$I+}
|
||||
if (ioresult<>0) then print('File not found.') else begin
|
||||
abort:=FALSE;
|
||||
print('^X = Abort -- ^S = Pause');
|
||||
print('Press <CR> 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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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)+'<DIR> '
|
||||
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('<CR>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.
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
------------------------------------
|
||||
-- Telegard Bulletin Board System --
|
||||
-- Version 2.5i Standard --
|
||||
-- Source code in Pascal --
|
||||
------------------------------------
|
||||
|
|
@ -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.
|
||||
|
|
@ -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;
|
||||
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 }
|
||||
|
||||
|
|
@ -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;
|
||||
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
cd\bbs2
|
||||
copy BBS*.* c:\temp
|
||||
cd\tg25i
|
||||
copy bbs.exe c:\bbs2
|
||||
copy bbs.ovr c:\bbs2
|
||||
|
||||
|
|
@ -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) *}
|
||||
|
||||
|
|
@ -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 <filename> 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)<w do s:=c+s;
|
||||
mrn:=s;
|
||||
end;
|
||||
|
||||
function mnz(l:longint; w:integer):string;
|
||||
begin
|
||||
mnz:=mrn(cstr(l),w,'0');
|
||||
end;
|
||||
|
||||
function mn(l:longint; w:integer):string;
|
||||
begin
|
||||
mn:=mrn(cstr(l),w,' ');
|
||||
end;
|
||||
|
||||
{*------------------------------------------------------------------------*}
|
||||
|
||||
procedure abend(message:string);
|
||||
begin
|
||||
{* abend() - Display error message and abort to DOS. Returns
|
||||
* ERRORLEVEL of 1.
|
||||
*}
|
||||
|
||||
writeln;
|
||||
writeln('** '+message+' **');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
{*------------------------------------------------------------------------*}
|
||||
|
||||
procedure details;
|
||||
var i,month,day,year,hour,minute,typ:integer;
|
||||
ampm:char;
|
||||
ratio:longint;
|
||||
outp:string;
|
||||
begin
|
||||
{* details - Calculate and display details line.
|
||||
*}
|
||||
|
||||
typ:=out.typ;
|
||||
for i:=1 to length(out.filename) do
|
||||
out.filename[i]:=upcase(out.filename[i]);
|
||||
day:=out.date and $1f; {* day = bits 4-0 *}
|
||||
month:=(out.date shr 5) and $0f; {* month = bits 8-5 *}
|
||||
year:=((out.date shr 9) and $7f)+80; {* year = bits 15-9 *}
|
||||
minute:=(out.time shr 5) and $3f; {* minute = bits 10-5 *}
|
||||
hour:=(out.time shr 11) and $1f; {* hour = bits 15-11 *}
|
||||
|
||||
if month>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.
|
||||
|
|
@ -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,<CR>,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.
|
||||
|
|
@ -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,<CR>,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.
|
||||
|
|
@ -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<paramcount) do begin
|
||||
inc(a);
|
||||
if ((sc(paramstr(a),1)='-') or (sc(paramstr(a),1)='/')) then
|
||||
case sc(paramstr(a),2) of
|
||||
'B':answerbaud:=atoi(copy(paramstr(a),3,length(paramstr(a))-2));
|
||||
'E':if (length(paramstr(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.
|
||||
|
|
@ -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}
|
||||
);
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
lastcompiled='Last official compilation date: < 6:54 pm Thu May 03, 1990 >';
|
||||
|
|
@ -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.
|
||||
|
|
@ -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)<j) then begin
|
||||
checkbday:=TRUE;
|
||||
exit;
|
||||
end;
|
||||
inc(i);
|
||||
until (i>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 (lng<trunc(nsl/60.0)) then
|
||||
begin
|
||||
choptime:=(nsl-(lng*60.0))+120.0; onlinetime; exit;
|
||||
end;
|
||||
end;
|
||||
lng:=1; lng2:=trunc(nsl/60);
|
||||
if (lng2>180) 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.
|
||||
|
|
@ -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)<j) then begin
|
||||
checkbday:=TRUE;
|
||||
exit;
|
||||
end;
|
||||
inc(i);
|
||||
until (i>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 (lng<trunc(nsl/60.0)) then
|
||||
begin
|
||||
choptime:=(nsl-(lng*60.0))+120.0; onlinetime; exit;
|
||||
end;
|
||||
end;
|
||||
lng:=1; lng2:=trunc(nsl/60);
|
||||
if (lng2>180) 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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 (cur<filesize(uf)) and (cur>0) 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! <idiot!>
|
||||
}
|
||||
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.
|
||||
|
|
@ -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 ((l<lc) and (not abort)) do begin
|
||||
if (linenum) then print(cstr(l)+':');
|
||||
if ((pos(^[,li[l])=0) and (pos(^[,lasts)=0)) then dosansion:=FALSE;
|
||||
|
||||
reading_a_msg:=TRUE;
|
||||
if ((pub) and (aacs(memboard.mciacs))) then read_with_mci:=TRUE;
|
||||
printacr(li[l],abort,next);
|
||||
read_with_mci:=FALSE;
|
||||
reading_a_msg:=FALSE;
|
||||
|
||||
lasts:=li[l];
|
||||
inc(l);
|
||||
end;
|
||||
|
||||
dosansion:=FALSE;
|
||||
if (disptotal) then
|
||||
sprint(' ^3Total number of lines were: ^4[^3'+cstr(lc-1)+'^4] ');
|
||||
saveline:=FALSE;
|
||||
end;
|
||||
|
||||
{rcg11172000 had to change this to get it compiling under Free Pascal...}
|
||||
{procedure rpl(var v:astr; old,new:astr);}
|
||||
procedure rpl(var v:astr; old,_new:astr);
|
||||
var p:integer;
|
||||
begin
|
||||
p:=pos(old,v);
|
||||
if (p>0) 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 <CR> 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))<systat.minspaceforpost) then begin
|
||||
mftit:='';
|
||||
nl;
|
||||
print('Not enough disk space to save a message.');
|
||||
c:=chr(exdrv(systat.msgpath)+64);
|
||||
if (c='@') then sysoplog(#3#8+'>>>>'+#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 (t<lc) then begin
|
||||
for t1:=t to lc-2 do
|
||||
li[t1]:=li[t1+1];
|
||||
dec(lc);
|
||||
end;
|
||||
end;
|
||||
'I':if (lc<maxli) then begin
|
||||
prt('Insert before which line (1-'+cstr(lc-1)+') ? ');
|
||||
input(s,4);
|
||||
t:=value(s);
|
||||
if (t>0) and (t<lc) then begin
|
||||
for t1:=lc downto t+1 do li[t1]:=li[t1-1];
|
||||
inc(lc);
|
||||
sprint(#3#3+'New line:');
|
||||
inli(li[t]);
|
||||
end;
|
||||
end else
|
||||
sprint(#3#7+'Too many lines!');
|
||||
'L':listit(1,pynq('With line numbers? '),TRUE);
|
||||
'R':begin
|
||||
prt('Line number to replace (1-'+cstr(lc-1)+') ? ');
|
||||
input(s,4);
|
||||
t:=value(s);
|
||||
if ((t>0) and (t<lc)) then begin
|
||||
abort:=FALSE;
|
||||
nl;
|
||||
sprint(#3#3+'Old line:');
|
||||
printacr(li[t],abort,next);
|
||||
sprint(#3#3+'Enter new line:');
|
||||
inli(s);
|
||||
if (li[t][length(li[t])]=#1) and
|
||||
(s[length(s)]<>#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 <CR> 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<strlen) and (rp+cv<thisuser.linelen) then
|
||||
for cc:=1 to cv do begin
|
||||
outkey(' '); if (trapping) then write(trapfile,' ');
|
||||
i[cp]:=' ';
|
||||
inc(rp); inc(cp);
|
||||
end;
|
||||
end;
|
||||
^J:if (not (rbackspace in thisuser.ac)) then begin
|
||||
outkey(c); i[cp]:=c;
|
||||
if (trapping) then write(trapfile,^J);
|
||||
inc(cp);
|
||||
end;
|
||||
^N:if (not (rbackspace in thisuser.ac)) then begin
|
||||
outkey(^H); i[cp]:=^H;
|
||||
if (trapping) then write(trapfile,^H);
|
||||
inc(cp); dec(rp);
|
||||
end;
|
||||
^P:if (okansi) and (cp<strlen-1) then begin
|
||||
getkey(c1);
|
||||
if (c1 in ['0'..'9']) then begin
|
||||
ccc:=c1; i[cp]:=#3;
|
||||
inc(cp); i[cp]:=chr(ord(c1)-ord('0'));
|
||||
inc(cp); cl(ord(i[cp-1]));
|
||||
end;
|
||||
end;
|
||||
^S:dm(' '+nam+' ',c);
|
||||
^W:if (cp=1) then begin
|
||||
hitcmdkey:=TRUE;
|
||||
hitbkspc:=TRUE;
|
||||
end else
|
||||
repeat bkspc until (cp=1) or (i[cp]=' ') or
|
||||
((i[cp]=^H) and (i[cp-1]<>#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<strlen) and (escp)) or
|
||||
((rp<thisuser.linelen) and (not escp)) then begin
|
||||
if (c=^[) then escp:=TRUE;
|
||||
i[cp]:=c; inc(cp); inc(rp);
|
||||
outkey(c);
|
||||
if (trapping) then write(trapfile,c);
|
||||
inc(pap);
|
||||
end;
|
||||
until ((rp=(thisuser.linelen)) and (not escp)) or ((cp=strlen) and (escp)) or
|
||||
(c=^M) or (hitcmdkey) or (hangup);
|
||||
|
||||
if (hitcmdkey) then begin
|
||||
if (hitbkspc) then i:='/'^H else i:='/';
|
||||
end else begin
|
||||
i[0]:=chr(cp-1);
|
||||
if (c<>^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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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! <grin> }
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -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<l2) then exit;
|
||||
if (l1=l2) then begin
|
||||
l1:=zzzb(msgdate[4],16);
|
||||
inc(l1,zzzb(msgdate[5],8));
|
||||
inc(l1,msgdate[6]);
|
||||
l2:=zzzb(mhiread[board][4],16);
|
||||
inc(l2,zzzb(mhiread[board][5],8));
|
||||
inc(l2,mhiread[board][6]);
|
||||
if (l1<=l2) then exit;
|
||||
end;
|
||||
isnew1:=TRUE;
|
||||
end;
|
||||
end;
|
||||
|
||||
function isnew(cn:integer):boolean;
|
||||
var mixr:msgindexrec;
|
||||
begin
|
||||
ensureloaded(cn);
|
||||
mixr:=mintab[getmixnum(cn)];
|
||||
isnew:=isnew1(@mixr.msgdate);
|
||||
end;
|
||||
|
||||
procedure updateptr(x:word; var zup:boolean);
|
||||
var mixr:msgindexrec;
|
||||
l1,l2:longint;
|
||||
i:integer;
|
||||
begin
|
||||
if (isnew(x)) then begin
|
||||
ensureloaded(x);
|
||||
mixr:=mintab[getmixnum(x)];
|
||||
for i:=1 to 6 do zscanr.mhiread[board][i]:=mixr.msgdate[i];
|
||||
zup:=TRUE;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure editmessage(i:integer);
|
||||
var t:text;
|
||||
f:file;
|
||||
g:text;
|
||||
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);
|
||||
|
||||
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+'<<Unvalidated>>';
|
||||
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(^H' '^H);
|
||||
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<systat.maxpubpost)) then begin
|
||||
nl;
|
||||
if pynq('Post on '+#3#5+memboard.name+#3#7+'? ') then
|
||||
post(-1,mheader.fromi);
|
||||
end;
|
||||
if (zup) then savezscanr;
|
||||
end;
|
||||
|
||||
procedure scanmessages;
|
||||
var cn:word;
|
||||
s:string;
|
||||
i:integer;
|
||||
c:char;
|
||||
quit:boolean;
|
||||
begin
|
||||
initbrd(board); { loads memboard }
|
||||
nl;
|
||||
if (himsg<>-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.
|
||||
|
|
@ -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<himsg) then inc(i);
|
||||
'C':begin
|
||||
nl;
|
||||
print('Continuous message listing on.');
|
||||
contlist:=TRUE;
|
||||
end;
|
||||
'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;
|
||||
'G':begin
|
||||
prt('Goto which message? (1-'+cstr(himsg)+') : ');
|
||||
inu(j);
|
||||
if (not badini) then
|
||||
if ((j>=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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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<menur.forcehelplevel) then chelplevel:=menur.forcehelplevel;
|
||||
end;
|
||||
|
||||
procedure getcmd(var s:string);
|
||||
var s1,ss,oss,shas0,shas1:string;
|
||||
i,newarea:integer;
|
||||
c,cc:char;
|
||||
oldco:byte;
|
||||
achange,bb,gotcmd,has0,has1,has2: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;
|
||||
|
||||
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)<length(oss)) then prompt(^H' '^H);
|
||||
end;
|
||||
if ((not (ss[1] in ['0'..'9'])) and
|
||||
((length(ss)=2) and (length(oss)=1))) then cl(6);
|
||||
|
||||
until ((gotcmd) or (hangup));
|
||||
|
||||
if (copy(ss,1,2)='//') then ss:=copy(ss,3,length(ss)-2);
|
||||
|
||||
s:=ss;
|
||||
end;
|
||||
|
||||
nl;
|
||||
|
||||
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;
|
||||
|
||||
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+'[<Time Left - '+tlef+'>]');
|
||||
sprompt(menur.menuprompt);
|
||||
end;
|
||||
|
||||
getcmd(cmd);
|
||||
|
||||
if (cmd='?') then
|
||||
begin
|
||||
cmd:='';
|
||||
inc(chelplevel);
|
||||
if (chelplevel>3) then chelplevel:=3;
|
||||
if ((menur.tutorial='*OFF*') and (chelplevel>=3)) then chelplevel:=2;
|
||||
end else
|
||||
if (menur.forcehelplevel<>0) then chelplevel:=menur.forcehelplevel
|
||||
else
|
||||
if (novice in thisuser.ac) then chelplevel:=2 else chelplevel:=1;
|
||||
|
||||
checkforcelevel;
|
||||
|
||||
if (fqarea) or (mqarea) then begin
|
||||
newarea:=value(cmd);
|
||||
if ((newarea<>0) or (copy(cmd,1,1)='0')) then begin
|
||||
if (fqarea) then begin
|
||||
if (newarea>=0) and (newarea<=maxuboards) then
|
||||
changefileboard(ccuboards[0][newarea]);
|
||||
end else
|
||||
if (mqarea) then
|
||||
if (newarea>=0) and (newarea<=maxboards) then
|
||||
changeboard(ccboards[0][newarea]);
|
||||
cmd:='';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure fcmd(cmd:string; var i:integer; noc:integer;
|
||||
var cmdexists,cmdnothid:boolean);
|
||||
var done:boolean;
|
||||
begin
|
||||
done:=FALSE;
|
||||
repeat
|
||||
inc(i);
|
||||
if (cmd=cmdr[i].ckeys) then begin
|
||||
cmdexists:=TRUE;
|
||||
if (oksecurity(i,cmdnothid)) then done:=TRUE;
|
||||
end;
|
||||
until ((i>noc) or (done));
|
||||
if (i>noc) then i:=0;
|
||||
end;
|
||||
|
||||
procedure domenuexec(cmd:string; var newmenucmd:string);
|
||||
var cmdacs,cmdnothid,cmdexists,done:boolean;
|
||||
nocsave,i:integer;
|
||||
begin
|
||||
if (newmenucmd<>'') then begin cmd:=newmenucmd; newmenucmd:=''; end;
|
||||
if (cmd<>'') then begin
|
||||
cmdacs:=FALSE; cmdexists:=FALSE; cmdnothid:=FALSE; done:=FALSE;
|
||||
nocsave:=noc; i:=0;
|
||||
repeat
|
||||
fcmd(cmd,i,nocsave,cmdexists,cmdnothid);
|
||||
if (i<>0) then begin
|
||||
cmdacs:=TRUE;
|
||||
domenucommand(done,cmdr[i].cmdkeys+cmdr[i].mstring,newmenucmd);
|
||||
end;
|
||||
until ((i=0) or (done));
|
||||
if (not done) then
|
||||
if ((not cmdacs) and (cmd<>'')) then begin
|
||||
nl;
|
||||
if ((cmdnothid) and (cmdexists)) then
|
||||
print('You don''t have enough access for this command.')
|
||||
else
|
||||
print('Invalid command.');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure domenucommand(var done:boolean; cmd:string; var newmenucmd:string);
|
||||
var filvar:text;
|
||||
mheader:mheaderrec;
|
||||
cms,s,s1,s2:string;
|
||||
i:integer;
|
||||
c1,c2,c:char;
|
||||
abort,next,b,nocmd:boolean;
|
||||
|
||||
function semicmd(x:integer):string;
|
||||
var s:string;
|
||||
i,p:integer;
|
||||
begin
|
||||
s:=cms; i:=1;
|
||||
while (i<x) and (s<>'') do begin
|
||||
p:=pos(';',s);
|
||||
if (p<>0) then s:=copy(s,p+1,length(s)-p) else s:='';
|
||||
inc(i);
|
||||
end;
|
||||
while (pos(';',s)<>0) do s:=copy(s,1,pos(';',s)-1);
|
||||
semicmd:=s;
|
||||
end;
|
||||
|
||||
begin
|
||||
newmenutoload:=FALSE;
|
||||
newmenucmd:='';
|
||||
c1:=cmd[1]; c2:=cmd[2];
|
||||
cms:=copy(cmd,3,length(cmd)-2);
|
||||
nocmd:=FALSE;
|
||||
lastcommandovr:=FALSE;
|
||||
case c1 of
|
||||
'-':case c2 of
|
||||
'C':commandline(cms);
|
||||
'F':printf(cms);
|
||||
'L':begin nl; sprint(cms); end;
|
||||
'Q':readq(systat.afilepath+cms,0);
|
||||
'R':readasw1(cms);
|
||||
'S':sysoplog(cms);
|
||||
';':begin
|
||||
s:=cms;
|
||||
while (pos(';',s)<>0) do s[pos(';',s)]:=^M;
|
||||
dm(' '+s,c);
|
||||
end;
|
||||
'$':if (semicmd(1)<>'') then begin
|
||||
if (semicmd(2)='') then prt(':') else prt(semicmd(2));
|
||||
input(s,20);
|
||||
if (s<>semicmd(1)) then begin
|
||||
done:=TRUE;
|
||||
if (semicmd(3)<>'') then sprint(semicmd(3));
|
||||
end;
|
||||
end;
|
||||
'^','/','\':dochangemenu(done,newmenucmd,c2,cms);
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'A':case c2 of
|
||||
'A','C','M','T','X':doarccommand(c2);
|
||||
'E':extracttotemp;
|
||||
'G':userarchive;
|
||||
'R':rezipstuff;
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'B':case c2 of
|
||||
'?':batchinfo;
|
||||
'C':if (cms='U') then clearubatch else clearbatch;
|
||||
'D':batchdl;
|
||||
'L':if (cms='U') then listubatchfiles else listbatchfiles;
|
||||
'R':if (cms='U') then removeubatchfiles else removebatchfiles;
|
||||
'U':batchul;
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'D':case c2 of
|
||||
'C','D','G','S','W','-':dodoorfunc(c2,cms);
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'F':case c2 of
|
||||
'A':fbasechange(done,cms);
|
||||
'B':browse;
|
||||
'D':idl;
|
||||
'F':searchd;
|
||||
'I':listopts;
|
||||
'L':listfiles;
|
||||
'N':nf(cms);
|
||||
'P':pointdate;
|
||||
'R':remove;
|
||||
'S':search;
|
||||
'U':iul;
|
||||
'V':lfii;
|
||||
'Y':yourfileinfo;
|
||||
'Z':setdirs;
|
||||
'@':createtempdir;
|
||||
'#':begin
|
||||
nl;
|
||||
print('Enter the number of the file base to change to it.');
|
||||
end;
|
||||
'$':fbasestats;
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'H':case c2 of
|
||||
'C':if pynq('@M@M'+cms) then begin
|
||||
cls;
|
||||
printf('logoff');
|
||||
hangup:=TRUE;
|
||||
hungup:=FALSE;
|
||||
end;
|
||||
'I':hangup:=TRUE;
|
||||
'M':begin
|
||||
nl; sprint(cms);
|
||||
hangup:=TRUE;
|
||||
end;
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'M':case c2 of
|
||||
'A':mbasechange(done,cms);
|
||||
'E':ssmail(cms);
|
||||
'J':dopurgepub(cms);
|
||||
'K':purgepriv;
|
||||
'L':smail(TRUE);
|
||||
'M':readmail;
|
||||
'N':nscan(cms);
|
||||
'P':begin
|
||||
post(-1,mheader.fromi);
|
||||
closebrd;
|
||||
end;
|
||||
'S':scanmessages;
|
||||
'U':ulist;
|
||||
'Z':chbds;
|
||||
'#':begin
|
||||
nl;
|
||||
print('Enter the number of the message base to change to it.');
|
||||
end;
|
||||
'$':mbasestats;
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'O':case c2 of
|
||||
'1'..'3':tshuttlelogon:=ord(c2)-48;
|
||||
'A':autovalidationcmd(cms);
|
||||
'B':abbs;
|
||||
'C':reqchat(cms);
|
||||
'I':begin
|
||||
nl; nl; sprint(#3#3+centre(verline(1)));
|
||||
sprint(#3#3+centre(verline(2))); nl; abort:=FALSE;
|
||||
printf('logon'); printf('system');
|
||||
end;
|
||||
'M':mmacro;
|
||||
'O':sysopstatus;
|
||||
'P':cstuff(value(cms),2,thisuser);
|
||||
'S':bulletins(cms);
|
||||
'T':tfiles;
|
||||
'V':vote;
|
||||
'Y':yourinfo;
|
||||
'$':TimeBank(cms);
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'U':case c2 of
|
||||
'A':replyamsg;
|
||||
'R':readamsg;
|
||||
'W':wamsg;
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
'*':case c2 of
|
||||
'B':if (checkpw) then begin
|
||||
sysoplog('* Message base edit');
|
||||
boardedit;
|
||||
end;
|
||||
'C':if (checkpw) then chuser;
|
||||
'D':begin
|
||||
sysoplog('* Entered MiniDos');
|
||||
minidos;
|
||||
end;
|
||||
'E':if (checkpw) then begin
|
||||
sysoplog('* Event edit');
|
||||
eventedit;
|
||||
end;
|
||||
'F':if (checkpw) then begin
|
||||
sysoplog('* File base edit');
|
||||
dlboardedit;
|
||||
end;
|
||||
'I':if (checkpw) then begin
|
||||
sysoplog('* Vote edit');
|
||||
initvotes;
|
||||
end;
|
||||
'L':showlogs;
|
||||
'N':tedit1;
|
||||
'P':if (checkpw) then begin
|
||||
sysoplog('* System configuration modification');
|
||||
changestuff;
|
||||
end;
|
||||
'T':if (checkpw) then begin
|
||||
sysoplog('* Tfile base edit');
|
||||
tfileedit;
|
||||
end;
|
||||
'U':if (checkpw) then begin
|
||||
sysoplog('* User editor');
|
||||
uedit1;
|
||||
end;
|
||||
'V':begin
|
||||
nl;
|
||||
if pynq('Do you want to re-output VOTES.TXT? ') then begin
|
||||
sysoplog('+ Re-outputted VOTES.TXT');
|
||||
voteprint;
|
||||
end;
|
||||
if pynq('Do you want to see VOTES.TXT? ') then begin
|
||||
sysoplog('+ Viewed VOTES.TXT');
|
||||
printfile(systat.afilepath+'votes.txt');
|
||||
end;
|
||||
end;
|
||||
'X':if (checkpw) then begin
|
||||
sysoplog('* Protocol editor');
|
||||
exproedit;
|
||||
end;
|
||||
'Z':begin
|
||||
sysoplog('+ Viewed ZLOG');
|
||||
zlog;
|
||||
end;
|
||||
'1':begin
|
||||
sysoplog('* Edited files'); editfiles;
|
||||
end;
|
||||
'2':begin
|
||||
sysoplog('* Sorted files'); sort;
|
||||
end;
|
||||
'3':if (checkpw) then begin
|
||||
sysoplog('* Read private mail'); mailr;
|
||||
end;
|
||||
'4':if (cms='') then do_unlisted_download
|
||||
else unlisted_download(cms);
|
||||
'5':move;
|
||||
'6':uploadall;
|
||||
'7':validatefiles;
|
||||
'8':addgifspecs;
|
||||
'9':packmessagebases;
|
||||
'#':if (checkpw) then begin
|
||||
sysoplog('* Menu edit');
|
||||
last_menu:=curmenu;
|
||||
menu_edit;
|
||||
first_time:=TRUE;
|
||||
curmenu:=last_menu;
|
||||
readin2;
|
||||
end;
|
||||
'$':dirf(TRUE);
|
||||
'%':dirf(FALSE);
|
||||
else nocmd:=TRUE;
|
||||
end;
|
||||
else
|
||||
nocmd:=TRUE;
|
||||
end;
|
||||
lastcommandgood:=not nocmd;
|
||||
if (lastcommandovr) then lastcommandgood:=FALSE;
|
||||
if (nocmd) then
|
||||
if (cso) then
|
||||
begin
|
||||
sysoplog('Invalid command : Cmdkeys "'+cmd+'"');
|
||||
nl; print('Invalid command : Cmdkeys "'+cmd+'"');
|
||||
end;
|
||||
if (newmenutoload) then
|
||||
begin
|
||||
readin2;
|
||||
lastcommandgood:=FALSE;
|
||||
if (newmenucmd='') then begin
|
||||
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;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,382 @@
|
|||
(*****************************************************************************)
|
||||
(*> <*)
|
||||
(*> MENUS2 .PAS - Written by Eric Oman <*)
|
||||
(*> <*)
|
||||
(*> Other menu functions - generic, list, etc. <*)
|
||||
(*> <*)
|
||||
(*****************************************************************************)
|
||||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit menus2;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
file4,
|
||||
common;
|
||||
|
||||
procedure readin;
|
||||
procedure showcmds(listtype:integer);
|
||||
function oksecurity(i:integer; var cmdnothid:boolean):boolean;
|
||||
procedure genericmenu(t:integer);
|
||||
procedure showthismenu;
|
||||
|
||||
implementation
|
||||
|
||||
procedure readin;
|
||||
var filv:text;
|
||||
s,lcmdlistentry:astr;
|
||||
i,j:integer;
|
||||
b:boolean;
|
||||
begin
|
||||
cmdlist:='';
|
||||
noc:=0;
|
||||
assign(filv,curmenu);
|
||||
{$I-} reset(filv); {$I-}
|
||||
if (ioresult<>0) then begin
|
||||
sysoplog('"'+curmenu+'" is MISSING.');
|
||||
print('"'+curmenu+'" is MISSING. Please inform SysOp.');
|
||||
print('Dropping back to fallback menu...');
|
||||
curmenu:=systat.menupath+menur.fallback+'.mnu';
|
||||
assign(filv,curmenu);
|
||||
{$I-} reset(filv); {$I-}
|
||||
if (ioresult<>0) then begin
|
||||
sysoplog('"'+curmenu+'" is MISSING - Hung user up.');
|
||||
print('Fallback menu is *also* MISSING. Please inform SysOp.');
|
||||
nl;
|
||||
print('Critical error; hanging up.');
|
||||
hangup:=TRUE;
|
||||
end;
|
||||
end;
|
||||
|
||||
if (not hangup) then begin
|
||||
with menur do begin
|
||||
readln(filv,menuname[1]);
|
||||
readln(filv,menuname[2]);
|
||||
readln(filv,menuname[3]);
|
||||
readln(filv,directive);
|
||||
readln(filv,tutorial);
|
||||
readln(filv,menuprompt);
|
||||
readln(filv,acs);
|
||||
readln(filv,password);
|
||||
readln(filv,fallback);
|
||||
readln(filv,forcehelplevel);
|
||||
readln(filv,gencols);
|
||||
for i:=1 to 3 do readln(filv,gcol[i]);
|
||||
readln(filv,s);
|
||||
s:=allcaps(s); menuflags:=[];
|
||||
if (pos('C',s)<>0) then menuflags:=menuflags+[clrscrbefore];
|
||||
if (pos('D',s)<>0) then menuflags:=menuflags+[dontcenter];
|
||||
if (pos('N',s)<>0) then menuflags:=menuflags+[nomenuprompt];
|
||||
if (pos('P',s)<>0) then menuflags:=menuflags+[forcepause];
|
||||
if (pos('T',s)<>0) then menuflags:=menuflags+[autotime];
|
||||
end;
|
||||
repeat
|
||||
inc(noc);
|
||||
with cmdr[noc] do begin
|
||||
readln(filv,ldesc);
|
||||
readln(filv,sdesc);
|
||||
readln(filv,ckeys);
|
||||
readln(filv,acs);
|
||||
readln(filv,cmdkeys);
|
||||
readln(filv,mstring);
|
||||
readln(filv,s);
|
||||
s:=allcaps(s); commandflags:=[];
|
||||
if (pos('H',s)<>0) then commandflags:=commandflags+[hidden];
|
||||
if (pos('U',s)<>0) then commandflags:=commandflags+[unhidden];
|
||||
end;
|
||||
until (eof(filv));
|
||||
close(filv);
|
||||
|
||||
mqarea:=FALSE; fqarea:=FALSE;
|
||||
lcmdlistentry:=''; j:=0;
|
||||
for i:=1 to noc do begin
|
||||
if (cmdr[i].ckeys<>lcmdlistentry) then begin
|
||||
b:=(aacs(cmdr[i].acs));
|
||||
if (b) then inc(j);
|
||||
(*
|
||||
if (b) and (j<>1) then cmdlist:=cmdlist+',';
|
||||
if (b) then cmdlist:=cmdlist+cmdr[i].ckeys;
|
||||
*)
|
||||
if (b) then begin
|
||||
if ((cmdr[i].ckeys<>'FIRSTCMD') and (cmdr[i].ckeys<>'GTITLE')) then begin
|
||||
if (j<>1) then cmdlist:=cmdlist+',';
|
||||
cmdlist:=cmdlist+cmdr[i].ckeys;
|
||||
end else dec(j);
|
||||
end;
|
||||
lcmdlistentry:=cmdr[i].ckeys;
|
||||
end;
|
||||
if (cmdr[i].cmdkeys='M#') then mqarea:=TRUE;
|
||||
if (cmdr[i].cmdkeys='F#') then fqarea:=TRUE;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure showcmds(listtype:integer);
|
||||
var i,j,numrows:integer;
|
||||
s,s1:astr;
|
||||
abort,next:boolean;
|
||||
|
||||
function type1(i:integer):astr;
|
||||
begin
|
||||
type1:=mn(i,3)+mlnnomci(cmdr[i].ckeys,3)+mlnnomci(cmdr[i].cmdkeys,4)+
|
||||
mlnnomci(cmdr[i].mstring,15);
|
||||
end;
|
||||
|
||||
function sfl(b:boolean; c:char):char;
|
||||
begin
|
||||
if (b) then sfl:=c else sfl:='-';
|
||||
end;
|
||||
|
||||
begin
|
||||
abort:=FALSE; next:=FALSE;
|
||||
if (noc<>0) then begin
|
||||
case listtype of
|
||||
0:begin
|
||||
printacr(#3#0+'NN'+sepr2+'Command '+sepr2+'Fl'+sepr2+
|
||||
'ACS '+sepr2+'Cmd'+sepr2+'MString',abort,next);
|
||||
printacr(#3#4+'==:==============:==:==========:==:========================================',abort,next);
|
||||
i:=1;
|
||||
while (i<=noc) and (not abort) and (not hangup) do begin
|
||||
printacr(#3#0+mn(i,2)+' '+#3#3+mlnnomci(cmdr[i].ckeys,14)+' '+
|
||||
sfl(hidden in cmdr[i].commandflags,'H')+
|
||||
sfl(unhidden in cmdr[i].commandflags,'U')+' '+
|
||||
#3#9+mlnnomci(cmdr[i].acs,10)+' '+
|
||||
#3#3+mlnnomci(cmdr[i].cmdkeys,2)+' '+
|
||||
cmdr[i].mstring,abort,next);
|
||||
inc(i);
|
||||
end;
|
||||
end;
|
||||
1:begin
|
||||
numrows:=(noc+2) div 3;
|
||||
i:=1;
|
||||
s:=#3#3+'NN:KK-Typ-MString ';
|
||||
s1:=#3#4+'==:======================';
|
||||
while (i<=numrows) and (i<3) do begin
|
||||
s:=s+' NN:KK-Typ-MString ';
|
||||
s1:=s1+' ==:======================';
|
||||
inc(i);
|
||||
end;
|
||||
printacr(s,abort,next);
|
||||
printacr(s1,abort,next);
|
||||
i:=0;
|
||||
repeat
|
||||
inc(i);
|
||||
s:=type1(i);
|
||||
for j:=1 to 2 do
|
||||
if i+(j*numrows)<=noc then
|
||||
s:=s+' '+type1(i+(j*numrows));
|
||||
printacr(#3#1+s,abort,next);
|
||||
until ((i>=numrows) or (abort) or (hangup));
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else print('**No Commands on this menu**');
|
||||
end;
|
||||
|
||||
function oksecurity(i:integer; var cmdnothid:boolean):boolean;
|
||||
begin
|
||||
oksecurity:=FALSE;
|
||||
if (unhidden in cmdr[i].commandflags) then cmdnothid:=TRUE;
|
||||
if (not aacs(cmdr[i].acs)) then exit;
|
||||
oksecurity:=TRUE;
|
||||
end;
|
||||
|
||||
procedure genericmenu(t:integer);
|
||||
var glin:array [1..maxmenucmds] of astr;
|
||||
s,s1:astr;
|
||||
gcolors:array [1..3] of byte;
|
||||
onlin,i,j,colsiz,numcols,numglin,maxright:integer;
|
||||
abort,next,b,cmdnothid:boolean;
|
||||
|
||||
function gencolored(keys,desc:astr; acc:boolean):astr;
|
||||
begin
|
||||
s:=desc;
|
||||
j:=pos(allcaps(keys),allcaps(desc));
|
||||
if (j<>0) and (pos(#3,desc)=0) then begin
|
||||
insert(#3+chr(gcolors[3]),desc,j+length(keys)+1);
|
||||
insert(#3+chr(gcolors[1]),desc,j+length(keys));
|
||||
if (acc) then insert(#3+chr(gcolors[2]),desc,j);
|
||||
if (j<>1) then
|
||||
insert(#3+chr(gcolors[1]),desc,j-1);
|
||||
end;
|
||||
gencolored:=#3+chr(gcolors[3])+desc;
|
||||
end;
|
||||
|
||||
function semicmd(s:string; x:integer):string;
|
||||
var i,p:integer;
|
||||
begin
|
||||
i:=1;
|
||||
while (i<x) and (s<>'') do begin
|
||||
p:=pos(';',s);
|
||||
if (p<>0) then s:=copy(s,p+1,length(s)-p) else s:='';
|
||||
inc(i);
|
||||
end;
|
||||
while (pos(';',s)<>0) do s:=copy(s,1,pos(';',s)-1);
|
||||
semicmd:=s;
|
||||
end;
|
||||
|
||||
procedure newgcolors(s:string);
|
||||
var s1:string;
|
||||
begin
|
||||
s1:=semicmd(s,1); if (s1<>'') then gcolors[1]:=value(s1);
|
||||
s1:=semicmd(s,2); if (s1<>'') then gcolors[2]:=value(s1);
|
||||
s1:=semicmd(s,3); if (s1<>'') then gcolors[3]:=value(s1);
|
||||
end;
|
||||
|
||||
procedure gen_tuto;
|
||||
var i,j:integer;
|
||||
b:boolean;
|
||||
begin
|
||||
numglin:=0; maxright:=0; glin[1]:='';
|
||||
for i:=1 to noc do begin
|
||||
b:=oksecurity(i,cmdnothid);
|
||||
if (((b) or (unhidden in cmdr[i].commandflags)) and
|
||||
(not (hidden in cmdr[i].commandflags))) then
|
||||
if (cmdr[i].ckeys='GTITLE') then begin
|
||||
inc(numglin); glin[numglin]:=cmdr[i].ldesc;
|
||||
j:=lenn(glin[numglin]); if (j>maxright) then maxright:=j;
|
||||
if (cmdr[i].mstring<>'') then newgcolors(cmdr[i].mstring);
|
||||
end else
|
||||
if (cmdr[i].ldesc<>'') then begin
|
||||
inc(numglin);
|
||||
glin[numglin]:=gencolored(cmdr[i].ckeys,cmdr[i].ldesc,b);
|
||||
j:=lenn(glin[numglin]); if (j>maxright) then maxright:=j;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure stripc(var s1:astr);
|
||||
var s:astr;
|
||||
i:integer;
|
||||
begin
|
||||
s:=''; i:=1;
|
||||
while (i<=length(s1)) do begin
|
||||
if (s1[i]=#3) then inc(i) else s:=s+s1[i];
|
||||
inc(i);
|
||||
end;
|
||||
s1:=s;
|
||||
end;
|
||||
|
||||
procedure fixit(var s:astr; len:integer);
|
||||
var s1:astr;
|
||||
begin
|
||||
s1:=s;
|
||||
stripc(s1);
|
||||
if (length(s1)<len) then
|
||||
s:=s+copy(' ',1,len-length(s1))
|
||||
else
|
||||
if (length(s1)>len) then s:=s1;
|
||||
end;
|
||||
|
||||
procedure gen_norm;
|
||||
var s1:astr;
|
||||
i,j:integer;
|
||||
b:boolean;
|
||||
begin
|
||||
s1:=''; onlin:=0; numglin:=1; maxright:=0; glin[1]:='';
|
||||
for i:=1 to noc do begin
|
||||
b:=oksecurity(i,cmdnothid);
|
||||
if (((b) or (unhidden in cmdr[i].commandflags)) and
|
||||
(not (hidden in cmdr[i].commandflags))) then begin
|
||||
if (cmdr[i].ckeys='GTITLE') then begin
|
||||
if (onlin<>0) then inc(numglin);
|
||||
glin[numglin]:=#2+cmdr[i].ldesc;
|
||||
inc(numglin); glin[numglin]:='';
|
||||
onlin:=0;
|
||||
if (cmdr[i].mstring<>'') then newgcolors(cmdr[i].mstring);
|
||||
end else begin
|
||||
if (cmdr[i].sdesc<>'') then begin
|
||||
inc(onlin); s1:=gencolored(cmdr[i].ckeys,cmdr[i].sdesc,b);
|
||||
if (onlin<>numcols) then fixit(s1,colsiz);
|
||||
glin[numglin]:=glin[numglin]+s1;
|
||||
end;
|
||||
if (onlin=numcols) then begin
|
||||
j:=lenn(glin[numglin]); if (j>maxright) then maxright:=j;
|
||||
inc(numglin); glin[numglin]:=''; onlin:=0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if (onlin=0) then dec(numglin);
|
||||
end;
|
||||
|
||||
function tcentered(c:integer; s:astr):astr;
|
||||
const spacestr=' ';
|
||||
begin
|
||||
c:=(c div 2)-(lenn(s) div 2);
|
||||
if (c<1) then c:=0;
|
||||
tcentered:=copy(spacestr,1,c)+s;
|
||||
end;
|
||||
|
||||
procedure dotitles;
|
||||
var i:integer;
|
||||
b:boolean;
|
||||
begin
|
||||
b:=FALSE;
|
||||
if (clrscrbefore in menur.menuflags) then begin
|
||||
cls;
|
||||
nl; nl;
|
||||
end;
|
||||
for i:=1 to 3 do
|
||||
if (menur.menuname[i]<>'') then begin
|
||||
if (not b) then begin nl; b:=TRUE; end;
|
||||
if (dontcenter in menur.menuflags) then
|
||||
printacr(menur.menuname[i],abort,next)
|
||||
else
|
||||
printacr(tcentered(maxright,menur.menuname[i]),abort,next);
|
||||
end;
|
||||
nl;
|
||||
end;
|
||||
|
||||
begin
|
||||
for i:=1 to 3 do gcolors[i]:=menur.gcol[i];
|
||||
numcols:=menur.gencols;
|
||||
case numcols of
|
||||
2:colsiz:=39; 3:colsiz:=25; 4:colsiz:=19;
|
||||
5:colsiz:=16; 6:colsiz:=12; 7:colsiz:=11;
|
||||
end;
|
||||
if (numcols*colsiz>=thisuser.linelen) then
|
||||
numcols:=thisuser.linelen div colsiz;
|
||||
abort:=FALSE; next:=FALSE;
|
||||
if (t=2) then gen_norm else gen_tuto;
|
||||
dotitles;
|
||||
for i:=1 to numglin do
|
||||
if (glin[i]<>'') then
|
||||
if (glin[i][1]<>#2) then
|
||||
printacr(glin[i],abort,next)
|
||||
else
|
||||
printacr(tcentered(maxright,copy(glin[i],2,length(glin[i])-1)),
|
||||
abort,next);
|
||||
end;
|
||||
|
||||
procedure showthismenu;
|
||||
var s:astr;
|
||||
begin
|
||||
case chelplevel of
|
||||
2:begin
|
||||
nofile:=TRUE; s:=menur.directive;
|
||||
if (s<>'') then begin
|
||||
if (pos('@S',s)<>0) then
|
||||
printf(substall(s,'@S',cstr(thisuser.sl)));
|
||||
if (nofile) then printf(substall(s,'@S',''));
|
||||
end;
|
||||
end;
|
||||
3:begin
|
||||
nofile:=TRUE; s:=menur.tutorial;
|
||||
if (s<>'') then begin
|
||||
if (pos('.',s)=0) then s:=s+'.tut';
|
||||
if (pos('@S',s)<>0) then
|
||||
printf(substall(s,'@S',cstr(thisuser.sl)));
|
||||
if (nofile) then printf(substall(s,'@S',''));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if ((nofile) and (chelplevel in [2,3])) then genericmenu(chelplevel);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
(*****************************************************************************)
|
||||
(*> <*)
|
||||
(*> MENUS3 .PAS - Written by Eric Oman <*)
|
||||
(*> <*)
|
||||
(*> Menu command execution routines. <*)
|
||||
(*> <*)
|
||||
(*****************************************************************************)
|
||||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit menus3;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
file0,
|
||||
common;
|
||||
|
||||
procedure dochangemenu(var done:boolean; var newmenucmd:astr;
|
||||
c2:char; mstr:astr);
|
||||
|
||||
implementation
|
||||
|
||||
procedure dochangemenu(var done:boolean; var newmenucmd:astr;
|
||||
c2:char; mstr:astr);
|
||||
var s,s1:astr;
|
||||
begin
|
||||
case c2 of
|
||||
'^':begin
|
||||
s1:=mstr;
|
||||
if (pos(';',s1)<>0) then s1:=copy(s1,1,pos(';',s1)-1);
|
||||
if (mstr<>'') then begin
|
||||
s:=mstr;
|
||||
if (pos(';',s)<>0) then s:=copy(s,pos(';',s)+1,length(s));
|
||||
if (copy(s,1,1)='C') then menustackptr:=0;
|
||||
if (pos(';',s)=0) or (length(s)=1) then s:=''
|
||||
else s:=copy(s,pos(';',s)+1,length(s));
|
||||
end;
|
||||
if (s1<>'') then begin
|
||||
last_menu:=curmenu; curmenu:=systat.menupath+s1+'.mnu';
|
||||
done:=TRUE;
|
||||
if (s<>'') then newmenucmd:=allcaps(s);
|
||||
newmenutoload:=TRUE;
|
||||
end;
|
||||
end;
|
||||
'/':begin
|
||||
s1:=mstr;
|
||||
if (pos(';',s1)<>0) then s1:=copy(s1,1,pos(';',s1)-1);
|
||||
if ((mstr<>'') and (menustackptr<>8)) then begin
|
||||
s:=mstr;
|
||||
if (pos(';',s)<>0) then s:=copy(s,pos(';',s)+1,length(s));
|
||||
if (copy(s,1,1)='C') then menustackptr:=0;
|
||||
if (pos(';',s)=0) or (length(s)=1) then s:=''
|
||||
else s:=copy(s,pos(';',s)+1,length(s));
|
||||
inc(menustackptr);
|
||||
menustack[menustackptr]:=stripname(curmenu);
|
||||
end;
|
||||
if (s1<>'') then begin
|
||||
last_menu:=curmenu; curmenu:=systat.menupath+s1+'.mnu';
|
||||
done:=TRUE;
|
||||
if (s<>'') then newmenucmd:=allcaps(s);
|
||||
newmenutoload:=TRUE;
|
||||
end;
|
||||
end;
|
||||
'\':begin
|
||||
s:=mstr;
|
||||
if (menustackptr<>0) then begin
|
||||
last_menu:=curmenu;
|
||||
curmenu:=systat.menupath+menustack[menustackptr];
|
||||
dec(menustackptr);
|
||||
end;
|
||||
if (copy(s,1,1)='C') then menustackptr:=0;
|
||||
done:=TRUE;
|
||||
if (pos(';',s)=0) then s:='' else
|
||||
newmenucmd:=allcaps(copy(s,pos(';',s)+1,length(s)));
|
||||
newmenutoload:=TRUE;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
(*****************************************************************************)
|
||||
(*> <*)
|
||||
(*> MENUS4 .PAS - Written by Eric Oman <*)
|
||||
(*> <*)
|
||||
(*> Menu command execution routines. <*)
|
||||
(*> <*)
|
||||
(*> <*)
|
||||
(*****************************************************************************)
|
||||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit menus4;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
common;
|
||||
|
||||
procedure autovalidationcmd(pw:astr);
|
||||
|
||||
implementation
|
||||
|
||||
procedure autovalidationcmd(pw:astr);
|
||||
var s:astr;
|
||||
ok:boolean;
|
||||
begin
|
||||
nl;
|
||||
if (pw='') then begin
|
||||
sysoplog('[> Auto-Validation command executed - No PW specified! Nothing done.');
|
||||
print('Sorry; this function is not available at this time.');
|
||||
exit;
|
||||
end;
|
||||
if (thisuser.sl=systat.autosl) and (thisuser.dsl=systat.autodsl) and
|
||||
(thisuser.ar=systat.autoar) then begin
|
||||
sysoplog('[> Already validated user executed Auto-Validation command');
|
||||
print('You''ve already been validated! You do not need to use this command.');
|
||||
exit;
|
||||
end;
|
||||
|
||||
print('Note (or warning, if you prefer):');
|
||||
print('The SysOp Log records ALL usage of this command.');
|
||||
print('Press <Enter> to abort.');
|
||||
nl;
|
||||
prt('Password: '); input(s,50);
|
||||
if (s='') then sprint(#3#7+'Function aborted.'^G)
|
||||
else begin
|
||||
ok:=(s=allcaps(pw));
|
||||
if (not ok) then begin
|
||||
sysoplog('[> User entered wrong password for Auto-Validation: "'+s+'"');
|
||||
sprint(#3#7+'Wrong!'^G);
|
||||
end else begin
|
||||
sysoplog('[> User correctly entered Auto-Validation password.');
|
||||
autovalidate(thisuser,usernum);
|
||||
topscr; commandline('User Validated.');
|
||||
printf('autoval');
|
||||
if (nofile) then begin
|
||||
nl;
|
||||
print('Correct. You are now validated.');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,402 @@
|
|||
(*****************************************************************************)
|
||||
(*> <*)
|
||||
(*> MISC1 .PAS - Written by Eric Oman <*)
|
||||
(*> <*)
|
||||
(*> Various miscellaneous functions used by the BBS. <*)
|
||||
(*> <*)
|
||||
(*> <*)
|
||||
(*****************************************************************************)
|
||||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit misc1;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
common;
|
||||
|
||||
procedure reqchat(x:astr);
|
||||
procedure TimeBank(s:astr);
|
||||
function ctp(t,b:longint):astr;
|
||||
procedure vote;
|
||||
|
||||
implementation
|
||||
|
||||
uses mail2;
|
||||
|
||||
procedure reqchat(x:astr);
|
||||
var c,ii,i:integer;
|
||||
r:char;
|
||||
chatted:boolean;
|
||||
s,why:astr;
|
||||
begin
|
||||
why:='';
|
||||
if (pos(';',x)<>0) then why:=copy(x,pos(';',x)+1,length(x));
|
||||
if (why='') then why:='^3Why do you want to chat?';
|
||||
nl;
|
||||
if ((chatt<systat.maxchat) or (cso)) then begin
|
||||
sprint(why);
|
||||
chatted:=FALSE;
|
||||
|
||||
prt(':'); mpl(70); inputl(s,70);
|
||||
|
||||
if (s<>'') then begin
|
||||
inc(chatt);
|
||||
if ((not sysop) or (rchat in thisuser.ac)) then
|
||||
if (length(s)<64) then
|
||||
sysoplog(#3#4+'Chat attempt: "'+#3#5+s+#3#4+'"')
|
||||
else begin
|
||||
sysoplog(#3#4+'Chat attempt:');
|
||||
sl1(#3#4+' "'+#3#5+s+#3#4+'"');
|
||||
end
|
||||
else begin
|
||||
sl1(#3#4+'Chat: "'+#3#5+s+#3#4+'"');
|
||||
commandline('Press <SPACE> to chat or <ENTER> to SHUT UP for rest of call');
|
||||
nl;
|
||||
sprint(fstring.chatcall1);
|
||||
nl;
|
||||
ii:=0; c:=0;
|
||||
repeat
|
||||
inc(ii);
|
||||
if (outcom) then sendcom1(^G);
|
||||
sprompt(fstring.chatcall2);
|
||||
if (outcom) then sendcom1(^G);
|
||||
if (shutupchatcall) then delay(1500)
|
||||
else
|
||||
for i:=1 to 5 do begin
|
||||
sound(800); delay(33);
|
||||
sound(1300); delay(35);
|
||||
sound(1700); delay(37);
|
||||
sound(2100); delay(39);
|
||||
sound(3200); delay(45);
|
||||
sound(2100); delay(39);
|
||||
sound(1700); delay(37);
|
||||
sound(1300); delay(35);
|
||||
sound(800);
|
||||
end;
|
||||
nosound;
|
||||
if (keypressed) then begin
|
||||
r:=readkey;
|
||||
case r of
|
||||
#32:begin
|
||||
commandline('');
|
||||
chatted:=TRUE; chatt:=0;
|
||||
pap:=0;
|
||||
chat;
|
||||
end;
|
||||
^M:shutupchatcall:=TRUE;
|
||||
end;
|
||||
end;
|
||||
until ((chatted) or (ii=9) or (hangup));
|
||||
commandline('');
|
||||
end;
|
||||
if (not chatted) then begin
|
||||
chatr:=s;
|
||||
printf('nosysop');
|
||||
if (value(x)<>0) then begin
|
||||
irt:='Tried chatting.';
|
||||
imail(value(x));
|
||||
end;
|
||||
end else
|
||||
chatr:='';
|
||||
tleft;
|
||||
end;
|
||||
end else begin
|
||||
printf('goaway');
|
||||
irt:='Tried chatting (more than '+cstr(systat.maxchat)+' times!)';
|
||||
sysoplog('Tried chatting more than '+cstr(systat.maxchat)+' times');
|
||||
imail(value(x));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TimeBank(s:astr);
|
||||
var lng,maxperday,maxever:longint;
|
||||
zz:integer;
|
||||
oc:astr;
|
||||
c:char;
|
||||
|
||||
function cantdeposit:boolean;
|
||||
begin
|
||||
cantdeposit:=TRUE;
|
||||
if ((thisuser.timebankadd>=maxperday) and (maxperday<>0)) then exit;
|
||||
if ((thisuser.timebank>=maxever) and (maxever<>0)) then exit;
|
||||
cantdeposit:=FALSE;
|
||||
end;
|
||||
|
||||
begin
|
||||
maxperday:=value(s); maxever:=0;
|
||||
if (pos(';',s)<>0) then maxever:=value(copy(s,pos(';',s)+1,length(s)));
|
||||
if ((maxever<>0) and (thisuser.timebank>maxever)) then
|
||||
thisuser.timebank:=maxever;
|
||||
nl; nl;
|
||||
sprint('^5Telegard Time Bank v'+ver);
|
||||
nl;
|
||||
if (not cantdeposit) then
|
||||
sprint('^3A^1)dd time to your account.');
|
||||
sprint('^3G^1)oodbye, log off now.');
|
||||
sprint('^3Q^1)uit to BBS.');
|
||||
if (choptime=0.0) then
|
||||
sprint('^3W^1)ithdraw time from your account.');
|
||||
nl;
|
||||
if (choptime<>0.0) then
|
||||
sprint(#3#7+'You cannot withdraw time during this call.');
|
||||
if (cantdeposit) then begin
|
||||
if ((thisuser.timebankadd>=maxperday) and (maxperday<>0)) then
|
||||
sprint(#3#7+'You cannot add any more time to your account today.');
|
||||
if ((thisuser.timebank>=maxever) and (maxever<>0)) then
|
||||
sprint(#3#7+'You cannot add any more time to your account!');
|
||||
end;
|
||||
nl;
|
||||
sprompt(#3#5+'In your account: '+#3#3+cstr(thisuser.timebank)+
|
||||
#3#5+' Time left online: '+#3#3+cstr(trunc(nsl) div 60));
|
||||
if (thisuser.timebankadd<>0) then
|
||||
sprompt(' ^5Deposited today: ^3'+cstr(thisuser.timebankadd));
|
||||
nl;
|
||||
sprompt(#3#5+'Account limits: '+#3#3);
|
||||
if (maxever<>0) then sprompt(cstr(maxever)+' max')
|
||||
else sprompt('No max limit');
|
||||
if (maxperday<>0) then sprompt(' / '+cstr(maxperday)+' per day');
|
||||
nl; nl;
|
||||
prt('Time Bank :');
|
||||
oc:='QG';
|
||||
if (choptime=0.0) then oc:=oc+'W';
|
||||
if (not cantdeposit) then oc:=oc+'A';
|
||||
onek(c,oc);
|
||||
case c of
|
||||
'A':begin
|
||||
prt('Add how many minutes? '); inu(zz); lng:=zz;
|
||||
nl;
|
||||
if (not badini) then
|
||||
if (lng>0) then
|
||||
if (lng>trunc(nsl) div 60) then
|
||||
sprint(#3#7+'You don''t have that much time left to deposit!')
|
||||
else
|
||||
if (lng+thisuser.timebankadd>maxperday) and (maxperday<>0) then
|
||||
sprint(#3#7+'You can only add '+cstr(maxperday)+' minutes to your account per day!')
|
||||
else
|
||||
if (lng+thisuser.timebank>maxever) and (maxever<>0) then
|
||||
sprint(#3#7+'Your account deposit limit is '+cstr(maxever)+' minutes!')
|
||||
else begin
|
||||
inc(thisuser.timebankadd,lng);
|
||||
inc(thisuser.timebank,lng);
|
||||
dec(thisuser.tltoday,lng);
|
||||
sprint('^5In your account: ^3'+cstr(thisuser.timebank)+
|
||||
'^5 Time left online: ^3'+cstr(trunc(nsl) div 60));
|
||||
sysoplog('TimeBank: Deposited '+cstr(lng)+' minutes.');
|
||||
end;
|
||||
end;
|
||||
'G':hangup:=TRUE;
|
||||
'W':begin
|
||||
prt('Withdraw how many minutes? '); inu(zz); lng:=zz;
|
||||
nl;
|
||||
if (not badini) then
|
||||
if (lng>thisuser.timebank) then
|
||||
sprint(#3#7+'You don''t have that much time left in your account!')
|
||||
else
|
||||
if (lng>0) then begin
|
||||
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: Withdrew '+cstr(lng)+' minutes.');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function ctp(t,b:longint):astr;
|
||||
var s,s1:astr;
|
||||
n:real;
|
||||
begin
|
||||
if ((t=0) or (b=0)) then begin
|
||||
ctp:=' 0.0%';
|
||||
exit;
|
||||
end;
|
||||
n:=(t*100)/b;
|
||||
str(n:5:1,s);
|
||||
s:=s+'%';
|
||||
ctp:=s;
|
||||
(*
|
||||
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;
|
||||
|
||||
function vote1x(answeringall:boolean; qnum:integer; var vd:vdatar):boolean;
|
||||
var s,pva:astr;
|
||||
i,tv:integer;
|
||||
c:char;
|
||||
abort,next,changed,doneyet,b:boolean;
|
||||
|
||||
procedure showvotes(stats,nocom:boolean);
|
||||
var s:astr;
|
||||
i:integer;
|
||||
begin
|
||||
cls;
|
||||
sprint('Current standings for Question #'+cstr(qnum)+' :');
|
||||
nl; sprint(#3#7+vd.question); nl;
|
||||
tv:=0;
|
||||
for i:=1 to vd.numa do inc(tv,vd.answ[i].numres);
|
||||
if (tv=0) then tv:=1;
|
||||
sprint('Users voting: '+#3#3+ctp(tv,systat.numusers)); nl;
|
||||
abort:=FALSE; i:=1;
|
||||
if (nocom) then begin
|
||||
sprint(#3#0+' 0:No Comment');
|
||||
pva:='Q0';
|
||||
end else
|
||||
pva:='';
|
||||
while (i<=vd.numa) do begin
|
||||
if (not abort) then begin
|
||||
s:=#3#5+cstr(i)+#3#7+':'+#3#3+vd.answ[i].ans;
|
||||
if (stats) then
|
||||
s:=mln(s,41+length(cstr(i)))+#3#4+' :'+#3#0+mn(vd.answ[i].numres,3)+
|
||||
#3#4+':'+#3#0+ctp(vd.answ[i].numres,tv)+#3#4+':';
|
||||
if (i=thisuser.vote[qnum]) then s:=#3#8+'*'+s else s:=' '+s;
|
||||
printacr(' '+s,abort,next);
|
||||
end;
|
||||
pva:=pva+cstr(i);
|
||||
inc(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
changed:=FALSE;
|
||||
if (vd.numa<>0) then begin
|
||||
doneyet:=(thisuser.vote[qnum]<>0);
|
||||
showvotes(doneyet,not systat.forcevoting);
|
||||
nl;
|
||||
sprint(#3#5+'Your vote: '+#3#3+vd.answ[thisuser.vote[qnum]].ans);
|
||||
if (not (rvoting in thisuser.ac)) and (not hangup) then begin
|
||||
if (answeringall) then b:=TRUE else b:=pynq('Change it? ');
|
||||
if (b) then begin
|
||||
nl; prt('Which number (0-'+cstr(vd.numa)+') ? ');
|
||||
onek(s[1],pva);
|
||||
s[0]:=#1; i:=value(s);
|
||||
if (s<>'') and (i>=0) and (i<=vd.numa) then begin
|
||||
if (thisuser.vote[qnum]<>0) then
|
||||
dec(vd.answ[thisuser.vote[qnum]].numres);
|
||||
thisuser.vote[qnum]:=i;
|
||||
if (i<>0) then inc(vd.answ[i].numres);
|
||||
changed:=TRUE;
|
||||
|
||||
if (not answeringall) then showvotes(TRUE,FALSE);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end else
|
||||
if (not answeringall) then print('Inactive question.');
|
||||
vote1x:=changed;
|
||||
end;
|
||||
|
||||
procedure vote;
|
||||
var vdata:file of vdatar;
|
||||
vd:vdatar;
|
||||
i,j,int2,vna:integer;
|
||||
s,i1,ij:astr;
|
||||
abort,next,done,lq,waschanged:boolean;
|
||||
|
||||
procedure getvote(qnum:integer);
|
||||
begin
|
||||
seek(vdata,qnum-1); read(vdata,vd);
|
||||
end;
|
||||
|
||||
procedure vote1(answeringall:boolean; qnum:integer);
|
||||
begin
|
||||
getvote(qnum);
|
||||
if (vote1x(answeringall,qnum,vd)) then begin
|
||||
seek(vdata,qnum-1);
|
||||
write(vdata,vd);
|
||||
waschanged:=TRUE;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
s:=''; done:=FALSE; lq:=TRUE; waschanged:=FALSE;
|
||||
assign(vdata,systat.gfilepath+'voting.dat');
|
||||
{$I-} reset(vdata); {$I+}
|
||||
if (ioresult<>0) then print('No voting today.')
|
||||
else begin
|
||||
sysoplog('Entered voting booths');
|
||||
repeat
|
||||
done:=FALSE;
|
||||
ij:='Q?';
|
||||
abort:=FALSE;
|
||||
if (lq) then begin
|
||||
cls;
|
||||
printacr(#3#5+'Current Questions:',abort,next);
|
||||
nl;
|
||||
end;
|
||||
int2:=0;
|
||||
for i:=1 to numvoteqs do begin
|
||||
seek(vdata,i-1); read(vdata,vd);
|
||||
if vd.numa<>0 then begin
|
||||
inc(int2);
|
||||
if (lq) and (not abort) then begin
|
||||
if (thisuser.vote[i]=0) then i1:=#3+#8+'* ' else i1:=' ';
|
||||
i1:=i1+#3#5+cstr(i)+#3#7+': '+#3#3+vd.question;
|
||||
printacr(i1,abort,next);
|
||||
end;
|
||||
ij:=ij+cstr(i);
|
||||
end;
|
||||
end;
|
||||
lq:=FALSE;
|
||||
if (int2=0) then begin
|
||||
print('No voting questions now.');
|
||||
done:=TRUE;
|
||||
end else begin
|
||||
nl;
|
||||
prt('Which question (##,L:ist,A:nswer all,Q:uit) : ');
|
||||
input(s,2);
|
||||
i:=value(s);
|
||||
if (s='A') then begin
|
||||
j:=0;
|
||||
i:=1;
|
||||
while ((i<=numvoteqs) and (not hangup)) do begin
|
||||
getvote(i);
|
||||
if ((vd.numa<>0) and (thisuser.vote[i]=0)) then begin
|
||||
vote1(TRUE,i);
|
||||
inc(j);
|
||||
end;
|
||||
inc(i);
|
||||
end;
|
||||
if (j=0) then begin nl; sprint(#3#7+'No more questions need answering!'); end;
|
||||
end;
|
||||
if ((s='Q') or (s='')) then done:=TRUE;
|
||||
if ((s='L') or (s='?')) then lq:=TRUE;
|
||||
if (i>=1) and (i<=numvoteqs) then vote1(FALSE,i);
|
||||
end;
|
||||
if (systat.forcevoting) and (done) then begin
|
||||
vna:=0;
|
||||
for i:=1 to numvoteqs do begin
|
||||
seek(vdata,i-1); read(vdata,vd);
|
||||
if ((vd.numa<>0) and (thisuser.vote[i]=0)) then inc(vna);
|
||||
end;
|
||||
if (vna<>0) then begin
|
||||
nl;
|
||||
print('Voting is mandatory - all questions must be answered.');
|
||||
done:=FALSE;
|
||||
end;
|
||||
end;
|
||||
until (done) or (hangup);
|
||||
|
||||
close(vdata);
|
||||
|
||||
if (waschanged) then begin
|
||||
nl;
|
||||
sprint(#3#3+fstring.thanxvote);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,619 @@
|
|||
(*****************************************************************************)
|
||||
(*> <*)
|
||||
(*> MISC2 .PAS - Written by Eric Oman <*)
|
||||
(*> <*)
|
||||
(*> Various miscellaneous functions used by the BBS. <*)
|
||||
(*> <*)
|
||||
(*> <*)
|
||||
(*****************************************************************************)
|
||||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit misc2;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
common,
|
||||
file2;
|
||||
|
||||
procedure pstat;
|
||||
procedure bulletins(par:astr);
|
||||
procedure abbs;
|
||||
procedure ansig(x,y:integer);
|
||||
procedure yourinfo;
|
||||
procedure tfiles;
|
||||
procedure ulist;
|
||||
|
||||
implementation
|
||||
|
||||
procedure pstat;
|
||||
var c:char;
|
||||
begin
|
||||
outkey(^L);
|
||||
with systat do begin
|
||||
print('New User Pass : '+newuserpw);
|
||||
prompt('Board is : '); if (closedsystem) then print('Closed') else print('Open');
|
||||
print('Number Users : '+cstr(numusers));
|
||||
print('Number calls : '+cstr(callernum));
|
||||
print('Date & Time : '+dat);
|
||||
print('Active today : '+cstr(systat.todayzlog.active));
|
||||
print('Calls today : '+cstr(systat.todayzlog.calls));
|
||||
print('Messages today : '+cstr(systat.todayzlog.pubpost));
|
||||
print('Email sent today: '+cstr(systat.todayzlog.privpost));
|
||||
print('Feed back today : '+cstr(systat.todayzlog.fback));
|
||||
print('Uploads today : '+cstr(systat.todayzlog.uploads));
|
||||
prompt('Sysop : '+aonoff(sysop,fstring.sysopin,fstring.sysopout));
|
||||
print('Disk free space : '+cstrl(freek(0))+'k');
|
||||
prompt('Sysop hours : ');
|
||||
if (lowtime=hitime) then print('None')
|
||||
else
|
||||
print(tch(cstr(lowtime div 60))+':'+tch(cstr(lowtime mod 60))+' to '+
|
||||
tch(cstr(hitime div 60))+':'+tch(cstr(hitime mod 60)));
|
||||
|
||||
end;
|
||||
if (not useron) then begin
|
||||
nl; nl; print('Hit any key');
|
||||
getkey(c);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure bulletins(par:astr);
|
||||
var filv:text;
|
||||
main,subs,s:astr;
|
||||
i:integer;
|
||||
begin
|
||||
nl;
|
||||
if (par='') then
|
||||
if (systat.bulletprefix='') then
|
||||
par:='bulletin;bullet'
|
||||
else
|
||||
par:='bulletin;'+systat.bulletprefix;
|
||||
if (pos(';',par)<>0) then begin
|
||||
main:=copy(par,1,pos(';',par)-1);
|
||||
subs:=copy(par,pos(';',par)+1,length(par)-pos(';',par));
|
||||
end else begin
|
||||
main:=par;
|
||||
subs:=par;
|
||||
end;
|
||||
printf(main);
|
||||
if (not nofile) then
|
||||
repeat
|
||||
i:=8-length(subs); if (i<1) then i:=1;
|
||||
prt(fstring.bulletinline);
|
||||
input(s,i); s:=sqoutsp(s);
|
||||
if (not hangup) then begin
|
||||
if (s='') then s:='Q';
|
||||
if (s='?') then printf(main);
|
||||
if ((s<>'Q') and (s<>'?') and (s<>'')) then printf(subs+s);
|
||||
end;
|
||||
until ((s='Q') or (hangup));
|
||||
end;
|
||||
|
||||
procedure abbs;
|
||||
var filvar:text;
|
||||
s,i1,i2:astr;
|
||||
c:char;
|
||||
tf:text;
|
||||
there,abort,next:boolean;
|
||||
begin
|
||||
abort:=FALSE; next:=FALSE;
|
||||
if (not (ramsg in thisuser.ac)) then begin
|
||||
nl;
|
||||
if pynq('Do you want to add to the BBS list? ') then begin
|
||||
repeat
|
||||
nl;
|
||||
print('Enter the phone number in the form:');
|
||||
sprint(#3#3+' '+systat.bbsphone);
|
||||
print(' ###-###-####');
|
||||
prt(':'); mpl(12); input(i1,12);
|
||||
until (length(i1)=12) or (i1='') or hangup;
|
||||
assign(tf,systat.afilepath+'bbslist.msg');
|
||||
{$I-} reset(tf); {$I+}
|
||||
nofile:=(ioresult<>0);
|
||||
there:=FALSE;
|
||||
if (not nofile) then begin
|
||||
while not eof(tf) do begin
|
||||
readln(tf,s);
|
||||
if (copy(s,1,12)=i1) then there:=TRUE;
|
||||
end;
|
||||
close(tf);
|
||||
end;
|
||||
if (there) then begin
|
||||
nl;
|
||||
if (i1<>'') then sprint(#3#5+'It''s already in there.');
|
||||
i1:='';
|
||||
end;
|
||||
s:=i1;
|
||||
if (s<>'') then begin
|
||||
nl;
|
||||
print('Enter the name of the BBS:');
|
||||
prt(':'); mpl(41); inputl(i1,41);
|
||||
s:=mln(s+' '+#3#0+i1,56);
|
||||
|
||||
nl;
|
||||
print('Enter max speed of system (ie, 300,1200,2400).');
|
||||
prt(':'); mpl(4); input(i2,4);
|
||||
if (i2='') then s:=s+' '
|
||||
else
|
||||
s:=s+#3#4+' ['+#3#3+i2+#3#4+']';
|
||||
if (i1<>'') then begin
|
||||
nl;
|
||||
print('Enter a 4-8 character BBS type.');
|
||||
prt(':');
|
||||
mpl(8);
|
||||
input(i1,8);
|
||||
if (i1<>'') then
|
||||
if copy(i1,1,3)<>'TAG' then s:=s+#3#7+' ('+#3#3+i1+#3#7+')'
|
||||
else s:=s+#3#7+' ('+#3#9+i1+#3#7+')';
|
||||
nl;
|
||||
printacr(s,abort,next);
|
||||
nl;
|
||||
if pynq('Is this correct? ') then begin
|
||||
assign(filvar,systat.afilepath+'bbslist.msg');
|
||||
{$I-} append(filvar); {$I+}
|
||||
if (ioresult<>0) then begin
|
||||
assign(filvar,systat.afilepath+'bbslist.msg');
|
||||
rewrite(filvar);
|
||||
end;
|
||||
writeln(filvar,s);
|
||||
close(filvar);
|
||||
sysoplog('Added to BBS list:');
|
||||
sl1(s);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else sprint(#3#7+'You are restricted from adding to the BBS list.');
|
||||
end;
|
||||
|
||||
procedure ansig(x,y:integer);
|
||||
begin
|
||||
if (spd<>'KB') then pr1(#27+'['+cstr(y)+';'+cstr(x)+'H');
|
||||
if (wantout) then gotoxy(x,y);
|
||||
pap:=0;
|
||||
end;
|
||||
|
||||
|
||||
procedure yourinfo;
|
||||
var ddt,dt:datetimerec;
|
||||
i:integer;
|
||||
|
||||
function istr(i:integer):astr;
|
||||
var s:astr;
|
||||
begin
|
||||
with thisuser do
|
||||
case i of
|
||||
1:s:=caps(name);
|
||||
2:s:=ph;
|
||||
3:s:=cstr(sl)+' SL';
|
||||
4:s:=cstr(dsl)+' DSL';
|
||||
5:s:=cstr(1+loggedon)+' calls';
|
||||
6:s:=cstr(ontoday)+' calls';
|
||||
7:s:=cstr(msgpost)+' posts';
|
||||
8:s:=cstr(emailsent+feedback)+' letters';
|
||||
9:begin
|
||||
s:=cstr(waiting)+' letter';
|
||||
if (waiting>1) then s:=s+'s';
|
||||
end;
|
||||
10:begin
|
||||
getdatetime(dt);
|
||||
timediff(ddt,timeon,dt);
|
||||
s:=ctim(dt2r(ddt));
|
||||
end;
|
||||
11:begin
|
||||
getdatetime(dt);
|
||||
timediff(ddt,timeon,dt);
|
||||
s:=cstrl(trunc(ttimeon+dt2r(ddt)))+' min.';
|
||||
end;
|
||||
12:s:=laston;
|
||||
end;
|
||||
istr:=s;
|
||||
end;
|
||||
|
||||
begin
|
||||
cls;
|
||||
if (okansi) then begin
|
||||
sprompt('ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'+#3#4+'['+#3#6+' User Statistics '+#3#4+']');
|
||||
sprint(#3#1'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿');
|
||||
print('³ Your name : ³ Public posts : ³');
|
||||
print('³ Phone number : ³ E-mail sent : ³');
|
||||
prompt('³ Sec Level : ³ ');
|
||||
if (thisuser.waiting>0) then cl(5);
|
||||
prompt('Mail waiting');
|
||||
sprint(#3#1+' : ³');
|
||||
print('³ DL Sec Level : ³ Time on today : ³');
|
||||
print('³ # times on : ³ Total time ever : ³');
|
||||
print('³ On today : ³ Last called : ³');
|
||||
print('ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ');
|
||||
cl(3);
|
||||
for i:=1 to 12 do begin
|
||||
if i in [1..6] then ansig(17,i+1);
|
||||
if i in [7..12] then ansig(55,i-5);
|
||||
if (i<>9) or (thisuser.waiting=0) then prompt(istr(i))
|
||||
else sprompt(#3#5+istr(i)+#3#3);
|
||||
end;
|
||||
ansig(1,9);
|
||||
cl(1);
|
||||
end else begin
|
||||
with thisuser do begin
|
||||
print('Your name : '+name);
|
||||
print('Phone number : '+ph);
|
||||
print('Sec Level : '+cstr(sl)+' SL');
|
||||
print('DL Sec Level : '+cstr(dsl)+' DSL');
|
||||
print('# times on : '+cstr(1+thisuser.loggedon));
|
||||
print('On today : '+cstr(thisuser.ontoday));
|
||||
nl;
|
||||
print('Public posts : '+cstr(thisuser.msgpost));
|
||||
print('E-mail sent : '+cstr(thisuser.emailsent+thisuser.feedback));
|
||||
print('Mail waiting : '+istr(9));
|
||||
print('Time on today : '+istr(10));
|
||||
print('Total time ever: '+istr(11));
|
||||
print('Last called : '+istr(12));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
(*
|
||||
procedure yourinfo;
|
||||
var s:string[90];
|
||||
c:char;
|
||||
abort,next:boolean;
|
||||
r:uflags;
|
||||
|
||||
function mlnn(i,l:integer):string;
|
||||
begin
|
||||
mlnn:=mln(cstr(i),l);
|
||||
end;
|
||||
|
||||
function mrnn(i,l:integer):string;
|
||||
begin
|
||||
mrnn:=mrn(cstr(i),l);
|
||||
end;
|
||||
|
||||
function yesno(x:boolean):string;
|
||||
var s:string[8];
|
||||
begin
|
||||
s:=#3#3+' ';
|
||||
if (x) then s:=s+'Y' else s:=s+'N';
|
||||
s:=s+' '+#3#1;
|
||||
yesno:=s;
|
||||
end;
|
||||
|
||||
begin
|
||||
cls;
|
||||
abort:=FALSE; next:=FALSE;
|
||||
printacr(#3#5+'Your user information (visible only to you):',abort,next);
|
||||
printacr('',abort,next);
|
||||
with thisuser do begin
|
||||
printacr(#3#1+' User Name: '+#3#3+mln(name,38)+#3#1+'SL: '+#3#3+mlnn(sl,3)+
|
||||
#3#1+' DSL: '+#3#3+cstr(dsl),abort,next);
|
||||
printacr(#3#1+' Real Name: '+#3#3+mln(realname,38)+#3#1+'Phone: '+#3#3+
|
||||
ph,abort,next);
|
||||
printacr(#3#1+' Address: '+#3#3+mln(street,38)+#3#1+' Age: '+#3#3+sex+
|
||||
cstr(ageuser(bday))+' ('+bday+')',abort,next);
|
||||
printacr(#3#1+'City/State: '+#3#3+mln(citystate,35)+#3#1+'First on: '+
|
||||
#3#3+firston,abort,next);
|
||||
printacr(#3#1+' Zip Code: '+#3#3+mln(zipcode,35)+#3#1+' Last on: '+#3#3+
|
||||
laston,abort,next);
|
||||
printacr('',abort,next);
|
||||
s:=mrnn(linelen,2)+'x'+mrnn(pagelen,2)+' (';
|
||||
if (avatar in ac) then s:=s+'AVATAR)'
|
||||
else if (ansi in ac) then s:=s+'ANSI)'
|
||||
else s:=s+'TTY)';
|
||||
printacr(#3#1+'Pause:'+yesno(pause in ac)+'OneKey:'+yesno(onekey in ac)+
|
||||
'ClrScr:'+yesno((clsmsg=1))+'Novice:'+yesno(novice in ac)+'Color:'+
|
||||
yesno(color in ac)+'Screen: '+#3#3+s,abort,next);
|
||||
s:=#3#1+'Mailbox Status: '+#3#3;
|
||||
if (nomail in ac) then s:=s+'Closed ' else begin
|
||||
if (forusr=0) then s:=s+'Open '
|
||||
else s:=s+'Fowarded to user '+mlnn(forusr,4);
|
||||
end;
|
||||
s:=s+#3#1+' File List Type: '+#3#3+cstr(flistopt);
|
||||
printacr(s,abort,next);
|
||||
printacr('',abort,next);
|
||||
printacr(#3#1+'Calls Today: '+#3#3+mlnn(ontoday,5)+#3#1+
|
||||
' Public Sent: '+#3#3+mlnn(msgpost,5)+#3#1+' Total ULs: '+#3#3+
|
||||
cstr(uploads)+#3#1+'/'+#3#3+cstrl(uk)+'K',abort,next);
|
||||
str(nsl/60.0:5:0,s);
|
||||
s:=mln(sqoutsp(s),5);
|
||||
printacr(#3#1+' Time Left: '+#3#3+s+#3#1+' Email Sent: '+#3#3+
|
||||
mlnn(emailsent,5)+#3#1+' Total DLs: '+#3#3+cstr(downloads)+#3#1+
|
||||
'/'+#3#3+cstrl(dk)+'K',abort,next);
|
||||
printacr(#3#1+'Total Calls: '+#3#3+mlnn(loggedon,5)+#3#1+' Feedback '+
|
||||
'Sent: '+#3#3+mlnn(feedback,5)+#3#1+' File Points: '+#3#3+
|
||||
cstr(filepoints),abort,next);
|
||||
s:=#3#1+' Total Time: '+#3#3+mlnn(ttimeon,5)+#3#1+' ';
|
||||
if (waiting<>0) then s:=s+#3#5;
|
||||
s:=s+'Email Waiting: ';
|
||||
if (waiting<>0) then s:=s+#3#8 else s:=s+#3#3;
|
||||
s:=s+mlnn(waiting,5)+#3#1+' Time Bank: '+#3#3+cstr(timebank);
|
||||
printacr(s,abort,next);
|
||||
end;
|
||||
pausescr;
|
||||
end;
|
||||
*)
|
||||
procedure tfiles;
|
||||
var gfil:file of tfilerec;
|
||||
b:tfilerec;
|
||||
gftit:array[1..150] of record
|
||||
tit:string[40];
|
||||
arn:integer;
|
||||
gfile:boolean;
|
||||
acs:acstring;
|
||||
{ arreq:acrq;}
|
||||
gdaten:integer;
|
||||
end;
|
||||
(*
|
||||
gftit:array[1..150] of record
|
||||
tit:string[40];
|
||||
filen:string[12];
|
||||
arn:integer;
|
||||
gfile:boolean;
|
||||
acs,ulacs:acstring;
|
||||
gdate:string[8];
|
||||
end;
|
||||
*)
|
||||
titl,s:astr;
|
||||
t,c,lgftn,lgftnt,numgft:integer;
|
||||
abort,next,deep,xexit:boolean;
|
||||
|
||||
procedure gettit(n:integer);
|
||||
var b:tfilerec;
|
||||
r:integer;
|
||||
begin
|
||||
numgft:=0;
|
||||
if n>0 then begin
|
||||
seek(gfil,n); read(gfil,b); titl:=b.title;
|
||||
end else titl:='[ Main Section ]';
|
||||
r:=n+1;
|
||||
if r<=t then begin
|
||||
seek(gfil,r); read(gfil,b);
|
||||
while (r<=t) and (b.filen[1]<>#1) do begin
|
||||
if (aacs(b.acs)) then begin
|
||||
inc(numgft);
|
||||
with gftit[numgft] do begin
|
||||
tit:=b.title;
|
||||
arn:=r;
|
||||
gfile:=TRUE;
|
||||
gdaten:=b.gdaten;
|
||||
end;
|
||||
end;
|
||||
inc(r);
|
||||
if (r<=t) then begin seek(gfil,r); read(gfil,b); end;
|
||||
end;
|
||||
end;
|
||||
if n=0 then
|
||||
while (r<=t) do begin
|
||||
seek(gfil,r); read(gfil,b);
|
||||
if ((b.filen[1]=#1) and (aacs(b.acs))) then begin
|
||||
inc(numgft);
|
||||
with gftit[numgft] do begin
|
||||
tit:=b.title;
|
||||
arn:=r;
|
||||
gfile:=FALSE;
|
||||
gdaten:=b.gdaten;
|
||||
end;
|
||||
end;
|
||||
inc(r);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure lgft;
|
||||
var abort,next:boolean; c:integer;
|
||||
begin
|
||||
nl; sprint(#3#3+titl); nl;
|
||||
if numgft=0 then print('No Tfiles.') else begin
|
||||
abort:=FALSE; next:=FALSE; c:=1;
|
||||
while (c<=numgft) and (not abort) do begin
|
||||
s:=#3#5+cstr(c)+#3#7+': '+#3#3+gftit[c].tit;
|
||||
if (gftit[c].gdaten>=daynum(thisuser.laston)) then s:=#3#8+'*'+s
|
||||
else s:=' '+s;
|
||||
printacr(s,abort,next);
|
||||
inc(c);
|
||||
end;
|
||||
end;
|
||||
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(^H' '^H);
|
||||
if (length(s)>length(os)) then prompt(copy(s,length(s),1));
|
||||
until ((gotcmd) or (hangup));
|
||||
nl;
|
||||
end;
|
||||
|
||||
procedure extracttfile;
|
||||
var dirinfo:searchrec;
|
||||
s,s2:string;
|
||||
lng,numfiles,tsiz:longint;
|
||||
i:integer;
|
||||
found,nospace,ok:boolean;
|
||||
begin
|
||||
nl;
|
||||
print('Extract text-file to temporary directory -');
|
||||
nl;
|
||||
prompt('Already in TEMP: ');
|
||||
numfiles:=0; tsiz:=0;
|
||||
findfirst(systat.temppath+'3\*.*',anyfile-dos.directory,dirinfo);
|
||||
found:=(doserror=0);
|
||||
while (found) do begin
|
||||
inc(tsiz,dirinfo.size);
|
||||
inc(numfiles);
|
||||
findnext(dirinfo);
|
||||
found:=(doserror=0);
|
||||
end;
|
||||
if (numfiles=0) then print('Nothing.')
|
||||
else print(cstrl(numfiles)+' files totalling '+cstrl(tsiz)+' bytes.');
|
||||
|
||||
if (not fso) then begin
|
||||
print('The limit is '+cstrl(systat.maxintemp)+'k bytes.');
|
||||
lng:=systat.maxintemp; lng:=lng*1024;
|
||||
if (tsiz>lng) 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('T-file #: ');
|
||||
scaninput(s,'');
|
||||
if ((hangup) or (s='')) then exit;
|
||||
i:=value(s);
|
||||
if ((i>=1) and (i<=numgft)) then
|
||||
if (gftit[i].gfile) then begin
|
||||
seek(gfil,gftit[i].arn); read(gfil,b);
|
||||
s:=systat.tfilepath+b.filen;
|
||||
s2:=systat.temppath+'3\'+b.filen;
|
||||
sprompt(#3#5+'Progress: ');
|
||||
copyfile(ok,nospace,TRUE,s,s2);
|
||||
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 t-file "'+b.filen+'" into TEMP directory.');
|
||||
(* if (ok) then didsomething:=TRUE;*)
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
nl;
|
||||
assign(gfil,systat.gfilepath+'gfiles.dat');
|
||||
{$I-} reset(gfil); {$I+}
|
||||
if ioresult<>0 then begin
|
||||
rewrite(gfil);
|
||||
b.gdaten:=0;
|
||||
write(gfil,b);
|
||||
end;
|
||||
seek(gfil,0); read(gfil,b); t:=b.gdaten;
|
||||
abort:=FALSE; next:=FALSE;
|
||||
if (t=0) then print('No Tfiles available today.')
|
||||
else begin
|
||||
gettit(0); xexit:=FALSE;
|
||||
lgft; lgftn:=0; deep:=FALSE; lgftnt:=0;
|
||||
repeat
|
||||
nl;
|
||||
if (next) then begin
|
||||
next:=FALSE; s:='';
|
||||
sprint(#3#5+'==Skipped to next==');
|
||||
nl;
|
||||
end else begin
|
||||
sprompt(#3#5+'['+cstr(lgftn)+'] '+#3#3+'Tfiles: (1-'+cstr(numgft)+',?,Q) : ');
|
||||
cl(5); scaninput(s,'QX?');
|
||||
nl;
|
||||
end;
|
||||
if (s='') then
|
||||
if (lgftn=numgft) then s:='Q' else s:=cstr(lgftn+1);
|
||||
if (s='?') then lgft;
|
||||
if (s='Q') then
|
||||
if (deep) then begin
|
||||
deep:=FALSE;
|
||||
gettit(0);
|
||||
lgft;
|
||||
lgftn:=lgftnt;
|
||||
end else
|
||||
xexit:=TRUE;
|
||||
if (s='X') then extracttfile;
|
||||
|
||||
c:=value(s);
|
||||
if ((c>0) and (c<=numgft)) then begin
|
||||
if (gftit[c].gfile) then begin
|
||||
seek(gfil,gftit[c].arn);
|
||||
read(gfil,b);
|
||||
if (pos('.',b.filen)<>0) then
|
||||
pfl(systat.tfilepath+b.filen,abort,next,TRUE)
|
||||
else printf(systat.tfilepath+b.filen);
|
||||
lgftn:=c;
|
||||
end else begin
|
||||
gettit(gftit[c].arn);
|
||||
lgftn:=c;
|
||||
if (numgft>0) then begin
|
||||
lgft;
|
||||
lgftnt:=c; lgftn:=0;
|
||||
deep:=TRUE;
|
||||
end else begin
|
||||
gettit(0);
|
||||
nl; print('No Tfiles there.');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
until ((xexit) or (hangup));
|
||||
end;
|
||||
close(gfil);
|
||||
end;
|
||||
|
||||
procedure ulist;
|
||||
const sepr2=#3#4+':'+#3#3;
|
||||
var u:userrec;
|
||||
sr:smalrec;
|
||||
s:astr;
|
||||
i,j:integer;
|
||||
abort,next,sfo:boolean;
|
||||
begin
|
||||
sfo:=(filerec(sf).mode<>fmclosed);
|
||||
if (not sfo) then reset(sf);
|
||||
nl;
|
||||
loadboard(board);
|
||||
sprint(#3#9+'Users with access to "'+#3#5+memboard.name+#3#9+'"');
|
||||
nl;
|
||||
sprint(#3#3+'User Name '+sepr2+
|
||||
'Computer Type '+sepr2+'Sex'+sepr2+'Last on');
|
||||
sprint(#3#4+'==========================:==============================:=:=========');
|
||||
reset(uf);
|
||||
i:=0; j:=0;
|
||||
abort:=FALSE;
|
||||
while (not abort) and (i<filesize(sf)-1) do begin
|
||||
inc(i);
|
||||
seek(sf,i); read(sf,sr); seek(uf,sr.number); read(uf,u);
|
||||
if (aacs1(u,sr.number,memboard.acs)) then begin
|
||||
printacr(#3#3+mln(caps(sr.name)+' #'+cstr(sr.number),26)+' '+
|
||||
mln(u.computer,30)+#3#3+' '+u.sex+' '+u.laston,abort,next);
|
||||
inc(j);
|
||||
end;
|
||||
end;
|
||||
if (not abort) then begin
|
||||
nl;
|
||||
s:=' User';
|
||||
if (j<>1) then s:=s+'s';
|
||||
s:=s+'.';
|
||||
printacr(#3#7+' ** '+#3#5+cstr(j)+s,abort,next);
|
||||
end;
|
||||
close(uf);
|
||||
if (not sfo) then close(sf);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,201 @@
|
|||
(*****************************************************************************)
|
||||
(*> <*)
|
||||
(*> MISC3 .PAS - Written by Eric Oman <*)
|
||||
(*> <*)
|
||||
(*> Various miscellaneous functions used by the BBS. <*)
|
||||
(*> <*)
|
||||
(*> <*)
|
||||
(*****************************************************************************)
|
||||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit misc3;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
common;
|
||||
|
||||
procedure mmacro;
|
||||
procedure finduserws(var usernum:integer);
|
||||
|
||||
implementation
|
||||
|
||||
procedure mmacro;
|
||||
var macrf:file of macrorec;
|
||||
c,mc:char;
|
||||
mcn,n,n1,mn:integer;
|
||||
done,macchanged:boolean;
|
||||
|
||||
procedure doctrl(c:char);
|
||||
begin
|
||||
cl(3); prompt('^'+c); cl(1);
|
||||
end;
|
||||
|
||||
procedure listmac(s:string);
|
||||
var i:integer;
|
||||
begin
|
||||
sprompt(#3#5+'"'+#3#1);
|
||||
for i:=1 to length(s) do
|
||||
if (s[i]>=' ') then prompt(s[i]) else doctrl(chr(ord(s[i])+64));
|
||||
sprint(#3#5+'"');
|
||||
end;
|
||||
|
||||
procedure listmacs;
|
||||
var i:integer;
|
||||
begin
|
||||
nl;
|
||||
sprint(#3#3+'Current Macros:');
|
||||
for i:=1 to 4 do begin
|
||||
nl; cl(5);
|
||||
case i of
|
||||
1:prompt('Ctrl-D: ');
|
||||
2:prompt('Ctrl-E: ');
|
||||
3:prompt('Ctrl-F: ');
|
||||
4:prompt('Ctrl-R: ');
|
||||
end;
|
||||
listmac(macros.macro[i]);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure mmacroo(c:char);
|
||||
var mc:char;
|
||||
n1,n,mcn,mn:integer;
|
||||
s:string[255];
|
||||
begin
|
||||
nl;
|
||||
mc:=c;
|
||||
cl(5); print('Enter new ^'+mc+' macro now.');
|
||||
cl(5); print('Enter ^'+mc+' to end recording. 240 character limit.');
|
||||
nl; mcn:=ord(mc)-64;
|
||||
n:=1; s:=''; macok:=FALSE;
|
||||
mn:=pos(mc,'DEFR');
|
||||
repeat
|
||||
getkey(c);
|
||||
{ if ((n<=240) and (c=chr(mcn))) then c:=#0;}
|
||||
|
||||
if (c=^H) then begin
|
||||
c:=#0;
|
||||
if (n>=2) then begin
|
||||
prompt(^H' '^H); dec(n);
|
||||
if (s[n]<#32) then prompt(^H' '^H);
|
||||
end;
|
||||
end;
|
||||
|
||||
if ((n<=240) and (c<>#0) and (c<>chr(mcn))) then begin
|
||||
if (c in [#32..#255]) then begin
|
||||
outkey(c);
|
||||
s[n]:=c; inc(n);
|
||||
end else
|
||||
if (c in [^A,^B,^C,^G,^I,^J,^K,^L,^M,^N,^P,^Q,^S,^T,
|
||||
^U,^V,^W,^X,^Y,^Z,#27,#28,#29,#30,#31]) then begin
|
||||
if (c=^M) then nl
|
||||
else doctrl(chr(ord(c)+64));
|
||||
s[n]:=c; inc(n);
|
||||
end;
|
||||
end;
|
||||
until ((c=chr(mcn)) or (hangup));
|
||||
s[0]:=chr(n-1);
|
||||
nl; nl;
|
||||
cl(3); print('Your ^'+mc+' macro is now:');
|
||||
nl; listmac(s); nl;
|
||||
com_flush_rx;
|
||||
if pynq('Is this what you want? ') then begin
|
||||
macros.macro[mn]:=s;
|
||||
print('Macro saved.');
|
||||
macchanged:=TRUE;
|
||||
end else
|
||||
print('Macro not saved.');
|
||||
macok:=TRUE;
|
||||
end;
|
||||
|
||||
begin
|
||||
macchanged:=FALSE;
|
||||
done:=FALSE;
|
||||
listmacs;
|
||||
repeat
|
||||
nl;
|
||||
prt('Macro modification (DEFR,?=help) : ');
|
||||
onek(c,'QLDEFR?');
|
||||
case c of
|
||||
'?':begin
|
||||
nl;
|
||||
print('D,E,F,R:Modify macro');
|
||||
lcmds(12,3,'List macros','Quit');
|
||||
end;
|
||||
'D','E','F','R':mmacroo(c);
|
||||
'L':listmacs;
|
||||
'Q':done:=TRUE;
|
||||
end;
|
||||
until (done) or (hangup);
|
||||
if (macchanged) then
|
||||
with thisuser do 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 (mpointer=-1) then mpointer:=filesize(macrf);
|
||||
seek(macrf,mpointer); write(macrf,macros); close(macrf);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure finduserws(var usernum:integer);
|
||||
var user:userrec;
|
||||
sr:smalrec;
|
||||
nn,duh:astr;
|
||||
t,i,i1,gg:integer;
|
||||
c:char;
|
||||
sfo,ufo,done,asked:boolean;
|
||||
begin
|
||||
ufo:=(filerec(uf).mode<>fmclosed);
|
||||
if (not ufo) then reset(uf);
|
||||
input(nn,36);
|
||||
usernum:=value(nn);
|
||||
if (nn='SYSOP') then nn:='1';
|
||||
if (usernum>0) then begin
|
||||
if (usernum>filesize(uf)-1) then begin
|
||||
print('Unknown User.');
|
||||
usernum:=0;
|
||||
end else begin
|
||||
seek(uf,usernum);
|
||||
read(uf,user);
|
||||
end;
|
||||
end else
|
||||
if (nn<>'') then begin
|
||||
sfo:=(filerec(sf).mode<>fmclosed);
|
||||
if (not sfo) then reset(sf);
|
||||
done:=FALSE; asked:=FALSE;
|
||||
gg:=0;
|
||||
while ((gg<filesize(sf)-1) and (not done)) do begin
|
||||
inc(gg);
|
||||
seek(sf,gg); read(sf,sr);
|
||||
if (pos(nn,sr.name)<>0) then
|
||||
if (sr.name=nn) then
|
||||
usernum:=sr.number
|
||||
else begin
|
||||
if (not asked) then begin nl; asked:=TRUE; end;
|
||||
sprint(#3#1+'Incomplete match --> '+#3#3+caps(sr.name)+' #'+
|
||||
cstr(sr.number));
|
||||
sprompt(#3#7+'Is this correct? (Y/N,Q=Quit) : ');
|
||||
onek(c,'QYN'^M);
|
||||
done:=TRUE;
|
||||
case c of
|
||||
'Q':usernum:=0;
|
||||
'Y':usernum:=sr.number;
|
||||
else
|
||||
done:=FALSE;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if (usernum=0) then print('User not found.');
|
||||
if (not sfo) then close(sf);
|
||||
end;
|
||||
if (not ufo) then close(uf);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,345 @@
|
|||
(*****************************************************************************)
|
||||
(*> <*)
|
||||
(*> MISC4 .PAS - InfoForm questionairre system. <*)
|
||||
(*> <*)
|
||||
(*****************************************************************************)
|
||||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit misc4;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
doors, misc3,
|
||||
common;
|
||||
|
||||
procedure readq(filen:astr; infolevel:integer);
|
||||
procedure readasw(usern:integer; fn:astr);
|
||||
procedure readasw1(fn:astr);
|
||||
|
||||
implementation
|
||||
|
||||
procedure readq(filen:astr; infolevel:integer);
|
||||
const level0name:string='';
|
||||
var infile,outfile,outfile1:text;
|
||||
outp,lin,s,mult,got,lastinp,ps,ns,es,infilename,outfilename:astr;
|
||||
i:integer;
|
||||
abort,next,plin:boolean;
|
||||
c:char;
|
||||
|
||||
procedure gotolabel(got:astr);
|
||||
var s:astr;
|
||||
begin
|
||||
got:=':'+allcaps(got);
|
||||
reset(infile);
|
||||
repeat
|
||||
readln(infile,s);
|
||||
until (eof(infile)) or (allcaps(s)=got);
|
||||
end;
|
||||
|
||||
procedure dumptofile;
|
||||
begin
|
||||
{ output answers to *.ASW file, and delete temporary file }
|
||||
reset(outfile1);
|
||||
{$I-} append(outfile); {$I+}
|
||||
if (ioresult<>0) then rewrite(outfile);
|
||||
|
||||
while (not eof(outfile1)) do begin
|
||||
readln(outfile1,s);
|
||||
writeln(outfile,s);
|
||||
end;
|
||||
close(outfile1); close(outfile);
|
||||
erase(outfile1);
|
||||
end;
|
||||
|
||||
begin
|
||||
infilename:=filen;
|
||||
if (not exist(infilename)) then begin
|
||||
fsplit(infilename,ps,ns,es);
|
||||
infilename:=ps+ns+'.INF';
|
||||
if (not exist(infilename)) then begin
|
||||
infilename:=systat.afilepath+ns+'.INF';
|
||||
if (not exist(infilename)) then begin
|
||||
sysoplog('** InfoForm not found: "'+filen);
|
||||
print('** InfoForm not found: "'+filen);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
assign(infile,infilename);
|
||||
{$I-} reset(infile); {$I+}
|
||||
if (ioresult<>0) then begin
|
||||
sysoplog('** InfoForm not found: "'+filen+'"');
|
||||
print('** InfoForm not found: "'+filen+'"');
|
||||
exit;
|
||||
end;
|
||||
|
||||
fsplit(infilename,ps,ns,es);
|
||||
outfilename:=systat.afilepath+ns+'.ASW';
|
||||
|
||||
assign(outfile1,systat.afilepath+'TEMP$'+cstr(infolevel)+'.ASW');
|
||||
if (infolevel=0) then begin
|
||||
level0name:=outfilename;
|
||||
assign(outfile,outfilename);
|
||||
sysoplog('** Answered InfoForm "'+filen+'"');
|
||||
rewrite(outfile1);
|
||||
writeln(outfile1,'User: '+nam);
|
||||
writeln(outfile1,'Date: '+dat);
|
||||
writeln(outfile1);
|
||||
end else begin
|
||||
sysoplog('**>> Answered InfoForm "'+filen+'"');
|
||||
rewrite(outfile1);
|
||||
assign(outfile,level0name);
|
||||
end;
|
||||
|
||||
nl;
|
||||
printingfile:=TRUE;
|
||||
|
||||
repeat
|
||||
abort:=FALSE;
|
||||
readln(infile,outp);
|
||||
if (pos('*',outp)<>0) and (copy(outp,1,1)<>';') then outp:=';A'+outp;
|
||||
if (length(outp)=0) then nl else
|
||||
case outp[1] of
|
||||
';':begin
|
||||
if (pos('*',outp)<>0) then
|
||||
if (outp[2]<>'D') then outp:=copy(outp,1,pos('*',outp)-1);
|
||||
lin:=copy(outp,3,length(outp)-2);
|
||||
i:=80-length(lin);
|
||||
s:=copy(outp,1,2);
|
||||
if (s[1]=';') then
|
||||
case s[2] of
|
||||
'C','D','G','I','K','L','Q','T',';':i:=1; { do nothing }
|
||||
else
|
||||
sprompt(lin);
|
||||
end;
|
||||
s:=#1#1#1;
|
||||
case outp[2] of
|
||||
'A':inputl(s,i);
|
||||
'B':input(s,i);
|
||||
'C':begin
|
||||
mult:=''; i:=1;
|
||||
s:=copy(outp,pos('"',outp),length(outp)-pos('"',outp));
|
||||
repeat
|
||||
mult:=mult+s[i];
|
||||
inc(i);
|
||||
until (s[i]='"') or (i>length(s));
|
||||
lin:=copy(outp,i+3,length(s)-(i-1));
|
||||
sprompt(lin);
|
||||
onek(c,mult);
|
||||
s:=c;
|
||||
end;
|
||||
'D':begin
|
||||
dodoorfunc(outp[3],copy(outp,4,length(outp)-3));
|
||||
s:=#0#0#0;
|
||||
end;
|
||||
'G':begin
|
||||
got:=copy(outp,3,length(outp)-2);
|
||||
gotolabel(got);
|
||||
s:=#0#0#0;
|
||||
end;
|
||||
'H':hangup:=TRUE;
|
||||
'I':begin
|
||||
mult:=copy(outp,3,length(outp)-2);
|
||||
i:=pos(',',mult);
|
||||
if i<>0 then begin
|
||||
got:=copy(mult,i+1,length(mult)-i);
|
||||
mult:=copy(mult,1,i-1);
|
||||
if allcaps(lastinp)=allcaps(mult) then
|
||||
gotolabel(got);
|
||||
end;
|
||||
s:=#0#0#0;
|
||||
end;
|
||||
'K':begin
|
||||
close(infile);
|
||||
close(outfile1); erase(outfile1);
|
||||
if (infolevel<>0) then begin
|
||||
{$I-} append(outfile); {$I+}
|
||||
if (ioresult<>0) then rewrite(outfile);
|
||||
writeln(outfile,'** Aborted InfoForm: "'+filen+'"');
|
||||
close(outfile);
|
||||
end;
|
||||
sysoplog('** Aborted InfoForm. Answers not saved.');
|
||||
printingfile:=FALSE; cfilteron:=FALSE;
|
||||
exit;
|
||||
end;
|
||||
'L':begin
|
||||
writeln(outfile1,copy(outp,3,length(outp)-2));
|
||||
s:=#0#0#0;
|
||||
end;
|
||||
'Q':begin
|
||||
close(outfile1);
|
||||
dumptofile;
|
||||
readq(copy(outp,3,length(outp)-2),infolevel+1);
|
||||
rewrite(outfile1);
|
||||
s:=#0#0#0;
|
||||
end;
|
||||
'T':begin
|
||||
s:=copy(outp,3,length(outp)-2);
|
||||
printf(s);
|
||||
s:=#0#0#0;
|
||||
end;
|
||||
'Y':if yn then s:='YES' else s:='NO';
|
||||
';':s:=#0#0#0;
|
||||
end;
|
||||
if (s<>#1#1#1) then begin
|
||||
outp:=lin+s;
|
||||
lastinp:=s;
|
||||
end;
|
||||
if (s=#0#0#0) then outp:=#0#0#0;
|
||||
end;
|
||||
':':outp:=#0#0#0;
|
||||
else
|
||||
printacr(outp,abort,next);
|
||||
end;
|
||||
if (outp<>#0#0#0) then begin
|
||||
if (pos('@7',outp)<>0) then delete(outp,pos('@7',outp),2);
|
||||
writeln(outfile1,outp);
|
||||
end;
|
||||
until ((eof(infile)) or (hangup));
|
||||
if (hangup) then begin
|
||||
writeln(outfile1);
|
||||
writeln(outfile1,'** HUNG UP **');
|
||||
end;
|
||||
|
||||
close(outfile1);
|
||||
dumptofile;
|
||||
close(infile);
|
||||
|
||||
printingfile:=FALSE; cfilteron:=FALSE;
|
||||
end;
|
||||
|
||||
procedure readasw(usern:integer; fn:astr);
|
||||
var qf:text;
|
||||
user:userrec;
|
||||
qs,ps,ns,es:astr;
|
||||
i,userntimes:integer;
|
||||
abort,next,userfound,usernfound,ufo:boolean;
|
||||
|
||||
procedure exactmatch;
|
||||
begin
|
||||
reset(qf);
|
||||
repeat
|
||||
readln(qf,qs);
|
||||
if (copy(qs,1,6)='User: ') then begin
|
||||
i:=value(copy(qs,pos('#',qs)+1,length(qs)-pos('#',qs)));
|
||||
if (i=usern) then begin
|
||||
inc(userntimes); usernfound:=TRUE;
|
||||
if (allcaps(qs)=allcaps('User: '+user.name+' #'+cstr(usern))) then
|
||||
userfound:=TRUE;
|
||||
end;
|
||||
end;
|
||||
if (not empty) then wkey(abort,next);
|
||||
until (eof(qf)) or (userfound) or (abort);
|
||||
end;
|
||||
|
||||
procedure usernmatch;
|
||||
begin
|
||||
sprompt(#3#7+'No exact user name matches; user number was found ');
|
||||
if (userntimes=1) then sprompt('once')
|
||||
else sprompt(cstr(userntimes)+' times');
|
||||
sprint('.');
|
||||
nl;
|
||||
|
||||
reset(qf);
|
||||
repeat
|
||||
readln(qf,qs);
|
||||
if (copy(qs,1,6)='User: ') then begin
|
||||
i:=value(copy(qs,pos('#',qs)+1,length(qs)-pos('#',qs)));
|
||||
if (i=usern) then
|
||||
if (userntimes=1) then userfound:=TRUE
|
||||
else begin
|
||||
sprompt(#3#4+'User: '+#3#3+copy(qs,7,length(qs)-6));
|
||||
userfound:=pynq(' -- Is this right? ');
|
||||
end;
|
||||
end;
|
||||
if (not empty) then wkey(abort,next);
|
||||
until (eof(qf)) or (userfound) or (abort);
|
||||
nl;
|
||||
end;
|
||||
|
||||
begin
|
||||
ufo:=(filerec(uf).mode<>fmclosed);
|
||||
if (not ufo) then reset(uf);
|
||||
if ((usern>=1) and (usern<=filesize(uf)-1)) then begin
|
||||
seek(uf,usern); read(uf,user);
|
||||
end else begin
|
||||
print('Invalid user number: '+cstr(usern));
|
||||
exit;
|
||||
end;
|
||||
if (not ufo) then close(uf);
|
||||
|
||||
nl;
|
||||
abort:=FALSE; next:=FALSE;
|
||||
fn:=allcaps(fn);
|
||||
fsplit(fn,ps,ns,es);
|
||||
fn:=allcaps(systat.afilepath+ns+'.ASW');
|
||||
if (not exist(fn)) then begin
|
||||
fn:=allcaps(systat.gfilepath+ns+'.ASW');
|
||||
if (not exist(fn)) then begin
|
||||
print('InfoForm answer file not found: "'+fn+'"');
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
assign(qf,fn);
|
||||
{$I-} reset(qf); {$I+}
|
||||
if (ioresult<>0) then print('"'+fn+'": unable to open.')
|
||||
else begin
|
||||
userfound:=FALSE; usernfound:=FALSE; userntimes:=0;
|
||||
exactmatch;
|
||||
if (not userfound) and (usernfound) and (not abort) then usernmatch;
|
||||
|
||||
if (not userfound) and (not abort) then
|
||||
print('Questionairre answers not found.')
|
||||
else begin
|
||||
sprint(qs); (*(#3#4+'User: '+#3#3+caps(user.name)+' #'+cstr(usern));*)
|
||||
repeat
|
||||
readln(qf,qs);
|
||||
if (copy(qs,1,6)<>'User: ') then printacr(qs,abort,next)
|
||||
else userfound:=FALSE;
|
||||
until eof(qf) or (not userfound) or (abort);
|
||||
end;
|
||||
close(qf);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure readasw1(fn:astr);
|
||||
var ps,ns,es:astr;
|
||||
usern:integer;
|
||||
begin
|
||||
nl;
|
||||
print('Read InfoForm answers -');
|
||||
nl;
|
||||
if (fn='') then begin
|
||||
prt('Enter filename: '); mpl(8); input(fn,8);
|
||||
nl;
|
||||
if (fn='') then exit;
|
||||
end;
|
||||
fsplit(fn,ps,ns,es);
|
||||
fn:=allcaps(systat.gfilepath+ns+'.ASW');
|
||||
if (not exist(fn)) then begin
|
||||
fn:=allcaps(systat.afilepath+ns+'.ASW');
|
||||
if (not exist(fn)) then begin
|
||||
print('InfoForm answer file not found: "'+fn+'"');
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
print('Enter user number, user name, or partial search string:');
|
||||
prt(':'); finduserws(usern);
|
||||
if (usern<>0) then
|
||||
readasw(usern,fn)
|
||||
else begin
|
||||
nl;
|
||||
if pynq('List entire answer file? ') then begin
|
||||
nl;
|
||||
printf(ns+'.ASW');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,324 @@
|
|||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit miscx;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
common,
|
||||
doors,
|
||||
misc1;
|
||||
|
||||
procedure finduser(var s:astr; var usernum:integer);
|
||||
procedure dsr(uname:astr);
|
||||
procedure ssm(dest:integer; s:astr);
|
||||
procedure isr(uname:astr;usernum:integer);
|
||||
procedure logon1st;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
archive1;
|
||||
|
||||
procedure finduser(var s:astr; var usernum:integer);
|
||||
var user:userrec;
|
||||
sr:smalrec;
|
||||
nn:astr;
|
||||
i,ii,t:integer;
|
||||
sfo,ufo:boolean;
|
||||
begin
|
||||
s:=''; usernum:=0;
|
||||
input(nn,36);
|
||||
if (nn='?') then begin
|
||||
|
||||
exit;
|
||||
end;
|
||||
while (copy(nn,1,1)=' ') do nn:=copy(nn,2,length(nn)-1);
|
||||
while (copy(nn,length(nn),1)=' ') do nn:=copy(nn,1,length(nn)-1);
|
||||
while (pos(' ',nn)<>0) do delete(nn,pos(' ',nn),1);
|
||||
if ((hangup) or (nn='')) then exit;
|
||||
s:=nn;
|
||||
usernum:=value(nn);
|
||||
if (usernum<>0) then begin
|
||||
if (usernum<0) then
|
||||
usernum:=-3 (* illegal negative number entry *)
|
||||
else begin
|
||||
ufo:=(filerec(uf).mode<>fmclosed);
|
||||
if (not ufo) then reset(uf);
|
||||
if (usernum>filesize(uf)-1) then begin
|
||||
print('Unknown User.');
|
||||
usernum:=0;
|
||||
end else begin
|
||||
seek(uf,usernum); read(uf,user);
|
||||
if (user.deleted) then begin
|
||||
print('Unknown User.');
|
||||
usernum:=0;
|
||||
end;
|
||||
end;
|
||||
if (not ufo) then close(uf);
|
||||
end;
|
||||
end else begin
|
||||
if (nn<>'') then begin
|
||||
sfo:=(filerec(sf).mode<>fmclosed);
|
||||
if (not sfo) then reset(sf);
|
||||
ii:=0; t:=1;
|
||||
while ((t<=filesize(sf)-1) and (ii=0)) do begin
|
||||
seek(sf,t); read(sf,sr);
|
||||
if (nn=sr.name) then ii:=sr.number;
|
||||
inc(t);
|
||||
end;
|
||||
if (ii<>0) then usernum:=ii;
|
||||
end;
|
||||
if (nn='NEW') then usernum:=-1;
|
||||
if (nn='GUEST') then
|
||||
if (systat.guestuser=-1) then
|
||||
print('No guest user account available.')
|
||||
else
|
||||
usernum:=-2;
|
||||
if (usernum=0) then print('Unknown User.');
|
||||
if (not sfo) then close(sf);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure ssm(dest:integer; s:astr);
|
||||
var u:userrec;
|
||||
x:smr;
|
||||
ufo:boolean;
|
||||
begin
|
||||
{$I-} reset(smf); {$I+}
|
||||
if (ioresult<>0) then rewrite(smf);
|
||||
seek(smf,filesize(smf));
|
||||
x.msg:=s; x.destin:=dest;
|
||||
write(smf,x);
|
||||
close(smf);
|
||||
|
||||
ufo:=(filerec(uf).mode<>fmclosed);
|
||||
if (not ufo) then reset(uf);
|
||||
if ((dest>=1) and (dest<=filesize(uf))) then begin
|
||||
seek(uf,dest); read(uf,u);
|
||||
if (not (smw in u.ac)) then begin
|
||||
u.ac:=u.ac+[smw];
|
||||
seek(uf,dest); write(uf,u);
|
||||
end;
|
||||
end;
|
||||
if (not ufo) then close(uf);
|
||||
if (dest=usernum) then thisuser.ac:=thisuser.ac+[smw];
|
||||
end;
|
||||
|
||||
procedure dsr(uname:astr);
|
||||
var t,ii:integer;
|
||||
sr:smalrec;
|
||||
sfo:boolean;
|
||||
begin
|
||||
sfo:=(filerec(sf).mode<>fmclosed);
|
||||
if (not sfo) then reset(sf);
|
||||
|
||||
ii:=0; t:=1;
|
||||
while ((t<=filesize(sf)-1) and (ii=0)) do begin
|
||||
seek(sf,t); read(sf,sr);
|
||||
if (sr.name=uname) then ii:=t;
|
||||
inc(t);
|
||||
end;
|
||||
|
||||
if (ii<>0) then begin
|
||||
if (ii<>filesize(sf)-1) then
|
||||
for t:=ii to filesize(sf)-2 do begin
|
||||
seek(sf,t+1); read(sf,sr);
|
||||
seek(sf,t); write(sf,sr);
|
||||
end;
|
||||
seek(sf,filesize(sf)-1); truncate(sf);
|
||||
dec(systat.numusers); savesystat;
|
||||
end
|
||||
else sl1('*** Couldn''t delete "'+uname+'"');
|
||||
if (not sfo) then close(sf);
|
||||
end;
|
||||
|
||||
procedure isr(uname:astr; usernum:integer);
|
||||
var t,i,ii:integer;
|
||||
sr:smalrec;
|
||||
sfo:boolean;
|
||||
begin
|
||||
sfo:=(filerec(sf).mode<>fmclosed);
|
||||
if (not sfo) then reset(sf);
|
||||
|
||||
if (filesize(sf)=1) then ii:=0
|
||||
else begin
|
||||
ii:=0; t:=1;
|
||||
while ((t<=filesize(sf)-1) and (ii=0)) do begin
|
||||
seek(sf,t); read(sf,sr);
|
||||
if (uname<sr.name) then ii:=t;
|
||||
inc(t);
|
||||
end;
|
||||
for i:=filesize(sf)-1 downto ii+1 do begin
|
||||
seek(sf,i); read(sf,sr);
|
||||
seek(sf,i+1); write(sf,sr);
|
||||
end;
|
||||
end;
|
||||
with sr do begin name:=uname; number:=usernum; end;
|
||||
seek(sf,ii+1); write(sf,sr);
|
||||
inc(systat.numusers); savesystat;
|
||||
if (not sfo) then close(sf);
|
||||
end;
|
||||
|
||||
procedure logon1st;
|
||||
var ul:text;
|
||||
u:userrec;
|
||||
zf:file of zlogrec;
|
||||
fil:file of astr;
|
||||
d1,d2:zlogrec;
|
||||
s,s1:astr;
|
||||
n,z,c1,num,rcode:integer;
|
||||
c:char;
|
||||
abort:boolean;
|
||||
begin
|
||||
if (spd<>'KB') then begin
|
||||
inc(systat.callernum);
|
||||
inc(systat.todayzlog.calls);
|
||||
end;
|
||||
|
||||
realsl:=thisuser.sl; realdsl:=thisuser.dsl;
|
||||
commandline('Purging files in TEMP directories 1, 2, and 3 ...');
|
||||
purgedir(systat.temppath+'1\');
|
||||
purgedir(systat.temppath+'2\');
|
||||
purgedir(systat.temppath+'3\');
|
||||
|
||||
if (systat.lastdate<>date) then begin
|
||||
prompt('Please wait ....');
|
||||
commandline('Updating user time left ...');
|
||||
reset(uf);
|
||||
for n:=1 to filesize(uf)-1 do begin
|
||||
seek(uf,n); read(uf,u);
|
||||
with u do begin
|
||||
tltoday:=systat.timeallow[sl];
|
||||
timebankadd:=0; ontoday:=0;
|
||||
end;
|
||||
seek(uf,n); write(uf,u);
|
||||
end;
|
||||
close(uf);
|
||||
|
||||
commandline('Updating ZLOG.DAT ...');
|
||||
assign(zf,systat.gfilepath+'zlog.dat');
|
||||
{$I-} reset(zf); {$I+}
|
||||
if (ioresult<>0) then begin
|
||||
rewrite(zf);
|
||||
d1.date:='';
|
||||
for n:=1 to 2 do write(zf,d1);
|
||||
end;
|
||||
|
||||
d1:=systat.todayzlog;
|
||||
d1.date:=systat.lastdate;
|
||||
|
||||
for n:=filesize(zf)-1 downto 0 do begin
|
||||
seek(zf,n); read(zf,d2);
|
||||
seek(zf,n+1); write(zf,d2);
|
||||
end;
|
||||
seek(zf,0);
|
||||
write(zf,d1);
|
||||
close(zf);
|
||||
systat.lastdate:=date;
|
||||
|
||||
commandline('Updating SysOp Log files ...');
|
||||
|
||||
assign(ul,systat.trappath+'sysop'+cstr(systat.backsysoplogs)+'.log');
|
||||
{$I-} erase(ul); {$I+} num:=ioresult;
|
||||
|
||||
for n:=systat.backsysoplogs-1 downto 1 do
|
||||
if (exist(systat.trappath+'sysop'+cstr(n)+'.log')) then begin
|
||||
assign(ul,systat.trappath+'sysop'+cstr(n)+'.log');
|
||||
rename(ul,systat.trappath+'sysop'+cstr(n+1)+'.log');
|
||||
end;
|
||||
|
||||
d1:=systat.todayzlog;
|
||||
sl1('');
|
||||
sl1('Total time on........: '+cstr(d1.active));
|
||||
sl1('Percent of activity..: '+sqoutsp(ctp(d1.active,1440))+' ('+
|
||||
cstr(d1.calls)+' calls)');
|
||||
sl1('New users............: '+cstr(d1.newusers));
|
||||
sl1('Public posts.........: '+cstr(d1.pubpost));
|
||||
sl1('Private mail sent....: '+cstr(d1.privpost));
|
||||
sl1('Feedback sent........: '+cstr(d1.fback));
|
||||
sl1('Critical Errors......: '+cstr(d1.criterr));
|
||||
sl1('Downloads today......: '+cstr(d1.downloads)+'-'+cstrl(d1.dk)+'k');
|
||||
sl1('Uploads today........: '+cstr(d1.uploads)+'-'+cstrl(d1.uk)+'k');
|
||||
|
||||
close(sysopf);
|
||||
rename(sysopf,systat.trappath+'sysop1.log');
|
||||
|
||||
assign(sysopf,systat.trappath+'sysop.log');
|
||||
rewrite(sysopf); close(sysopf); append(sysopf);
|
||||
sl1('');
|
||||
sl1(' ____________________________________');
|
||||
sl1('/ \');
|
||||
sl1('\ Coyote BBS log For '+date+': /');
|
||||
sl1(' \__________________________________/');
|
||||
sl1('');
|
||||
sl1('');
|
||||
|
||||
assign(ul,systat.gfilepath+'user.log');
|
||||
rewrite(ul);
|
||||
writeln(ul);
|
||||
writeln(ul,'Log of callers for '+date+':');
|
||||
writeln(ul);
|
||||
close(ul);
|
||||
|
||||
systat.todayzlog.date:=date;
|
||||
with systat.todayzlog do begin
|
||||
for n:=0 to 4 do userbaud[n]:=0;
|
||||
active:=0; calls:=0; newusers:=0; pubpost:=0; privpost:=0;
|
||||
fback:=0; criterr:=0; uploads:=0; downloads:=0; uk:=0; dk:=0;
|
||||
end;
|
||||
|
||||
if (exist('daystart.bat')) then
|
||||
shelldos(FALSE,process_door('daystart.bat @F @L @B @G @T @R'),rcode);
|
||||
|
||||
print(' thank you.'); nl;
|
||||
enddayf:=TRUE;
|
||||
end;
|
||||
|
||||
if (thisuser.slogseperate) then begin
|
||||
assign(sysopf1,systat.trappath+'slog'+cstr(usernum)+'.log');
|
||||
{$I-} append(sysopf1); {$I+}
|
||||
if (ioresult<>0) then begin
|
||||
rewrite(sysopf1);
|
||||
append(sysopf1);
|
||||
s:=''; s1:='';
|
||||
for n:=1 to 26+length(nam) do begin s:=s+'_'; s1:=s1+' '; end;
|
||||
writeln(sysopf1,'');
|
||||
writeln(sysopf1,' '+s);
|
||||
writeln(sysopf1,'>>'+s1+'<<');
|
||||
writeln(sysopf1,'>> Coyote BBS Log FOr '+nam+': <<');
|
||||
writeln(sysopf1,'>>'+s+'<<');
|
||||
writeln(sysopf1,'');
|
||||
end;
|
||||
writeln(sysopf1);
|
||||
s:=#3#3+'Logon '+#3#5+'['+dat+']'+#3#4+' (';
|
||||
if (spd<>'KB') then s:=s+spd+' baud)' else s:=s+'Keyboard)';
|
||||
if (systat.stripclog) then s:=stripcolor(s);
|
||||
writeln(sysopf1,s);
|
||||
end;
|
||||
|
||||
s:=#3#3+cstr(systat.callernum)+#3#4+' -- '+#3#0+nam+#3#4+' -- '+
|
||||
#3#3+'Today '+cstr(thisuser.ontoday+1);
|
||||
if (trapping) then s:=s+#3#0+'*';
|
||||
sl1(s);
|
||||
|
||||
if (spd<>'KB') then begin
|
||||
assign(ul,systat.gfilepath+'user.log');
|
||||
{$I-} append(ul); {$I+}
|
||||
if (ioresult<>0) then begin
|
||||
rewrite(ul);
|
||||
append(ul);
|
||||
end;
|
||||
s:=#3#5+mln(cstr(systat.callernum),6)+#3#9+'- '+
|
||||
#3#0+mln(nam,26)+#3#9+' - '+#3#3+time+#3#9+' -'+#3#3+mrn(spd,5);
|
||||
if (wasnewuser) then s:=s+#3#5+' <New User>';
|
||||
if (wasguestuser) then s:=s+#3#5+' <Guest User>';
|
||||
writeln(ul,s); close(ul);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,179 @@
|
|||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit mmodem;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
common,
|
||||
tmpcom,
|
||||
myio;
|
||||
|
||||
var
|
||||
p:array[1..2] of integer;
|
||||
ps:array[1..2] of astr;
|
||||
|
||||
procedure cwr(i:integer);
|
||||
procedure wr(i:integer; c:char);
|
||||
procedure wrs(i:integer; s:astr);
|
||||
procedure outmodemstring1(s:astr);
|
||||
procedure outmodemstring000(s:astr; showit:boolean);
|
||||
procedure outmodemstring(s:astr);
|
||||
procedure dophonehangup(showit:boolean);
|
||||
procedure dophoneoffhook(showit:boolean);
|
||||
|
||||
implementation
|
||||
|
||||
procedure cwr(i:integer);
|
||||
begin
|
||||
tc(12);
|
||||
ps[i]:=''; p[i]:=0;
|
||||
case i of
|
||||
1:begin
|
||||
cwriteat(2,25,'Telegard:'+#3#14);
|
||||
for i:=1 to 39 do write(' ');
|
||||
gotoxy(11,25);
|
||||
end;
|
||||
2:begin
|
||||
cwriteat(50,25,'Modem:'+#3#14);
|
||||
for i:=1 to 14 do write(' ');
|
||||
gotoxy(56,25);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure wr(i:integer; c:char);
|
||||
var j:integer;
|
||||
begin
|
||||
tc(14);
|
||||
case i of
|
||||
1:begin
|
||||
if (p[i]>37) then begin
|
||||
for j:=1 to 37 do ps[i][j]:=ps[i][j+1];
|
||||
ps[i][0]:=chr(37); p[i]:=37;
|
||||
end;
|
||||
gotoxy(11,25); write(ps[i]);
|
||||
end;
|
||||
2:begin
|
||||
if (p[i]>14) then begin
|
||||
for j:=1 to 14 do ps[i][j]:=ps[i][j+1];
|
||||
ps[i][0]:=chr(14); p[i]:=14;
|
||||
end;
|
||||
gotoxy(56,25); write(ps[i]);
|
||||
end;
|
||||
end;
|
||||
ps[i]:=ps[i]+c; inc(p[i]);
|
||||
write(c);
|
||||
end;
|
||||
|
||||
procedure wrs(i:integer; s:astr);
|
||||
var j:integer;
|
||||
begin
|
||||
for j:=1 to length(s) do wr(i,s[j]);
|
||||
end;
|
||||
|
||||
procedure outmodemstring1(s:astr);
|
||||
var i:integer;
|
||||
begin
|
||||
for i:=1 to length(s) do begin
|
||||
com_tx(s[i]); wr(1,s[i]);
|
||||
delay(2);
|
||||
end;
|
||||
if (s<>'') then com_tx(^M);
|
||||
end;
|
||||
|
||||
procedure outmodemstring000(s:astr; showit:boolean);
|
||||
var i:integer;
|
||||
begin
|
||||
for i:=1 to length(s) do
|
||||
case s[i] of
|
||||
'~':delay(500);
|
||||
else
|
||||
begin
|
||||
com_tx(s[i]);
|
||||
if (showit) then wr(1,s[i]);
|
||||
delay(2);
|
||||
end;
|
||||
end;
|
||||
com_tx(^M);
|
||||
end;
|
||||
|
||||
procedure outmodemstring(s:astr);
|
||||
begin
|
||||
outmodemstring000(s,TRUE);
|
||||
end;
|
||||
|
||||
procedure dophonehangup(showit:boolean);
|
||||
var rl:real;
|
||||
try,rcode:integer;
|
||||
c:char;
|
||||
|
||||
procedure dely(r:real);
|
||||
var r1:real;
|
||||
begin
|
||||
r1:=timer;
|
||||
while abs(timer-r1)<r do;
|
||||
end;
|
||||
|
||||
begin
|
||||
if (spd<>'KB') then begin
|
||||
if (showit) then begin
|
||||
gotoxy(1,24); tc(12); clreol; write('Hanging up phone...');
|
||||
cwr(1); cwr(2);
|
||||
end;
|
||||
try:=0;
|
||||
while ((try<6) and (com_carrier) and (not keypressed)) do begin
|
||||
term_ready(FALSE); dely(2.0); term_ready(TRUE);
|
||||
if (showit) then begin cwr(1); cwr(2); end;
|
||||
com_flush_rx;
|
||||
outmodemstring000(modemr.hangup,showit);
|
||||
rl:=timer;
|
||||
while (c<>'0') and (abs(timer-rl)<2.0) do begin
|
||||
c:=ccinkey1;
|
||||
if (c<>#0) then
|
||||
if (c in [#32..#255]) then
|
||||
if (showit) then wr(2,c);
|
||||
end;
|
||||
inc(try);
|
||||
end;
|
||||
term_ready(TRUE);
|
||||
if (keypressed) then c:=readkey;
|
||||
end;
|
||||
|
||||
if (showit) then
|
||||
if (exist('plogoff.bat')) then
|
||||
shelldos(FALSE,'plogoff.bat',rcode);
|
||||
end;
|
||||
|
||||
procedure dophoneoffhook(showit:boolean);
|
||||
var rl1:real;
|
||||
c:char;
|
||||
done:boolean;
|
||||
begin
|
||||
if (showit) then begin
|
||||
gotoxy(1,24); tc(12); clreol; write('Taking phone off hook...');
|
||||
end;
|
||||
delay(300); com_flush_rx;
|
||||
if (showit) then begin cwr(1); cwr(2); end;
|
||||
com_flush_rx; outmodemstring000(modemr.offhook,showit); com_flush_rx;
|
||||
rl1:=timer; done:=FALSE; c:=#0;
|
||||
repeat
|
||||
c:=ccinkey1;
|
||||
if (c<>#0) then begin
|
||||
if (c=^M) then done:=TRUE;
|
||||
if (c in [#32..#255]) then wr(2,c);
|
||||
end;
|
||||
until ((abs(timer-rl1)>1.0) or (done)) or (keypressed);
|
||||
delay(50); com_flush_rx;
|
||||
tc(11);
|
||||
if (showit) then begin
|
||||
gotoxy(1,24); clreol;
|
||||
gotoxy(1,25); clreol;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,133 @@
|
|||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit msgpack;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
crt, dos,
|
||||
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{overlay,}
|
||||
|
||||
common,
|
||||
mail0;
|
||||
|
||||
procedure packbase(fn:string; maxm:longint);
|
||||
|
||||
implementation
|
||||
|
||||
procedure packbase(fn:string; maxm:longint);
|
||||
var brdf1,brdf2:file;
|
||||
mixf1,mixf2:file of msgindexrec;
|
||||
mheader:mheaderrec;
|
||||
mixr,mixr2:msgindexrec;
|
||||
brdsig,mlength,numm,totload:longint;
|
||||
i,j,k:integer;
|
||||
s:string;
|
||||
done,isemail,sdone:boolean;
|
||||
|
||||
function iseq:boolean;
|
||||
var i:integer;
|
||||
begin
|
||||
iseq:=FALSE;
|
||||
if (mixr.isreplytoid<>mixr2.msgid) then exit;
|
||||
iseq:=TRUE;
|
||||
end;
|
||||
|
||||
begin
|
||||
fn:=allcaps(fn); isemail:=(fn='EMAIL');
|
||||
fn:=systat.msgpath+fn;
|
||||
|
||||
assign(brdf1,fn+'.BRD');
|
||||
{$I-} reset(brdf1,1); {$I+}
|
||||
if (ioresult<>0) then exit;
|
||||
|
||||
assign(mixf1,fn+'.MIX'); reset(mixf1);
|
||||
|
||||
assign(brdf2,fn+'.PK1'); rewrite(brdf2,1);
|
||||
assign(mixf2,fn+'.PK2'); rewrite(mixf2);
|
||||
|
||||
{ FIRST makes sure that filesize is greater than max messages...;
|
||||
if so, it then finds out how many undeleted messages there are,
|
||||
compares that with the max messages for base, and deletes the
|
||||
remainder from the beginning of the base. C'est ‡a, n'est-ce pas? }
|
||||
|
||||
if ((maxm<>0) and (filesize(mixf1)>maxm)) then begin
|
||||
numm:=0;
|
||||
seek(mixf1,0);
|
||||
while (filepos(mixf1)<filesize(mixf1)) do begin
|
||||
read(mixf1,mixr);
|
||||
if ((miexist in mixr.msgindexstat) and (mixr.hdrptr<>-1)) then inc(numm);
|
||||
end;
|
||||
if (numm>maxm) then begin
|
||||
dec(numm,maxm);
|
||||
seek(mixf1,0);
|
||||
while ((numm>0) and (filepos(mixf1)<filesize(mixf1))) do begin
|
||||
read(mixf1,mixr);
|
||||
if ((miexist in mixr.msgindexstat) and
|
||||
(not (mipermanent in mixr.msgindexstat))) then
|
||||
begin
|
||||
mixr.msgindexstat:=mixr.msgindexstat-[miexist];
|
||||
seek(mixf1,filepos(mixf1)-1); write(mixf1,mixr);
|
||||
dec(numm);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
i:=0;
|
||||
while (i<=filesize(mixf1)-1) do begin
|
||||
seek(mixf1,i);
|
||||
read(mixf1,mixr);
|
||||
if ((miexist in mixr.msgindexstat) and (mixr.hdrptr<>-1)) then begin
|
||||
seek(brdf1,mixr.hdrptr);
|
||||
loadmhead1(brdf1,i,mheader);
|
||||
seek(brdf1,mheader.msgptr);
|
||||
mixr.hdrptr:=filesize(brdf2);
|
||||
mheader.msgptr:=mixr.hdrptr+sizeof(mheaderrec);
|
||||
seek(brdf2,mixr.hdrptr);
|
||||
savemhead1(brdf2,mheader);
|
||||
totload:=0;
|
||||
repeat
|
||||
blockreadstr2(brdf1,s);
|
||||
blockwritestr2(brdf2,s);
|
||||
inc(totload,length(s)+2);
|
||||
until (totload>=mheader.msglength);
|
||||
|
||||
if ((not isemail) and (mixr.isreplyto<>65535) and
|
||||
(filesize(mixf2)<>0)) then begin
|
||||
done:=FALSE; sdone:=FALSE; j:=0; k:=filesize(mixf2);
|
||||
seek(mixf2,0);
|
||||
while (not done) do begin
|
||||
read(mixf2,mixr2);
|
||||
if (mixr.isreplytoid=mixr2.msgid) then begin
|
||||
done:=TRUE;
|
||||
sdone:=TRUE;
|
||||
end else begin
|
||||
inc(j);
|
||||
if (j>=k) then done:=TRUE;
|
||||
end;
|
||||
end;
|
||||
if (sdone) then mixr.isreplyto:=j else mixr.isreplyto:=65535;
|
||||
seek(mixf2,filesize(mixf2));
|
||||
end;
|
||||
write(mixf2,mixr);
|
||||
end;
|
||||
inc(i);
|
||||
end;
|
||||
|
||||
close(brdf1); erase(brdf1);
|
||||
close(brdf2); rename(brdf2,fn+'.BRD');
|
||||
close(mixf1); erase(mixf1);
|
||||
close(mixf2); rename(mixf2,fn+'.MIX');
|
||||
|
||||
if (not isemail) then begin
|
||||
assign(brdf,fn+'.BRD'); reset(brdf,1);
|
||||
assign(mixf,fn+'.MIX'); reset(mixf,sizeof(mixr));
|
||||
findhimsg;
|
||||
close(brdf);
|
||||
close(mixf);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
uses dos;
|
||||
|
||||
var f:file;
|
||||
r:array[1..144] of byte;
|
||||
res:word;
|
||||
i:integer;
|
||||
|
||||
begin
|
||||
assign(f,'bbs.ovr');
|
||||
reset(f,1);
|
||||
seek(f,filesize(f)-144);
|
||||
blockread(f,r,144,res);
|
||||
|
||||
for i:=1 to 144 do write(chr(r[i]));
|
||||
|
||||
writeln;
|
||||
writeln('143="'+chr(r[143])+'" (',r[143],')');
|
||||
writeln('144="'+chr(r[144])+'" (',r[144],')');
|
||||
|
||||
write('143:'); readln(r[143]);
|
||||
write('144:'); readln(r[144]);
|
||||
|
||||
seek(f,filesize(f)-144);
|
||||
blockwrite(f,r,144,res);
|
||||
close(f);
|
||||
end.
|
||||
|
|
@ -0,0 +1,513 @@
|
|||
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
|
||||
unit myio;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{rcg11172000 no overlay under Linux.}
|
||||
{crt, dos, overlay;}
|
||||
crt, dos;
|
||||
|
||||
const
|
||||
infield_seperators:set of char=[' ','\','.'];
|
||||
vidseg:word=$B800;
|
||||
ismono:boolean=FALSE;
|
||||
|
||||
type
|
||||
windowrec = array[0..4003] of byte;
|
||||
infield_special_function_proc_rec=procedure(c:char);
|
||||
|
||||
const
|
||||
infield_only_allow_on:boolean=FALSE;
|
||||
infield_arrow_exit:boolean=FALSE;
|
||||
infield_arrow_exited:boolean=FALSE;
|
||||
infield_arrow_exited_keep:boolean=FALSE;
|
||||
infield_special_function_on:boolean=FALSE;
|
||||
infield_arrow_exit_typedefs:boolean=FALSE;
|
||||
infield_normal_exit_keydefs:boolean=FALSE;
|
||||
infield_normal_exited:boolean=FALSE;
|
||||
|
||||
var
|
||||
infield_out_fgrd,
|
||||
infield_out_bkgd,
|
||||
infield_inp_fgrd,
|
||||
infield_inp_bkgd:byte;
|
||||
infield_last_arrow,
|
||||
infield_last_normal:byte;
|
||||
infield_only_allow:string;
|
||||
infield_special_function_proc:infield_special_function_proc_rec;
|
||||
infield_special_function_keys:string;
|
||||
infield_arrow_exit_types:string;
|
||||
infield_normal_exit_keys:string;
|
||||
|
||||
procedure cursoron(b:boolean);
|
||||
procedure infield1(x,y:byte; var s:string; len:byte);
|
||||
procedure infielde(var s:string; len:byte);
|
||||
procedure infield(var s:string; len:byte);
|
||||
function l_yn:boolean;
|
||||
function l_pynq(s:string):boolean;
|
||||
procedure cwrite(s:string);
|
||||
procedure cwriteat(x,y:integer; s:string);
|
||||
function cstringlength(s:string):integer;
|
||||
procedure cwritecentered(y:integer; s:string);
|
||||
procedure box(linetype,TLX,TLY,BRX,BRY:integer);
|
||||
procedure checkvidseg;
|
||||
procedure savescreen(var wind:windowrec; TLX,TLY,BRX,BRY:integer);
|
||||
procedure setwindow(var wind:windowrec; TLX,TLY,BRX,BRY,tcolr,bcolr,boxtype:integer);
|
||||
procedure removewindow(wind:windowrec);
|
||||
procedure removewindow1(wind:windowrec);
|
||||
procedure movewindow(wind:windowrec; TLX,TLY:integer);
|
||||
|
||||
implementation
|
||||
|
||||
procedure cursoron(b:boolean);
|
||||
var reg:registers;
|
||||
begin
|
||||
with reg do begin
|
||||
if (b) then begin ch:=$07; cl:=$08; end else begin ch:=$09; cl:=$00; end;
|
||||
ah:=1;
|
||||
intr($10,reg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure infield1(x,y:byte; var s:string; len:byte);
|
||||
var os:string;
|
||||
sta,sx,sy,z,i,p:integer;
|
||||
c:char;
|
||||
ins,done,nokeyyet:boolean;
|
||||
|
||||
procedure gocpos;
|
||||
begin
|
||||
gotoxy(x+p-1,y);
|
||||
end;
|
||||
|
||||
procedure exit_w_arrow;
|
||||
var i:integer;
|
||||
begin
|
||||
infield_arrow_exited:=TRUE;
|
||||
infield_last_arrow:=ord(c);
|
||||
done:=TRUE;
|
||||
if (infield_arrow_exited_keep) then begin
|
||||
z:=len;
|
||||
for i:=len downto 1 do
|
||||
if (s[i]=' ') then dec(z) else i:=1;
|
||||
s[0]:=chr(z);
|
||||
end else
|
||||
s:=os;
|
||||
end;
|
||||
|
||||
procedure exit_w_normal;
|
||||
var i:integer;
|
||||
begin
|
||||
infield_normal_exited:=TRUE;
|
||||
infield_last_normal:=ord(c);
|
||||
done:=TRUE;
|
||||
if (infield_arrow_exited_keep) then begin
|
||||
z:=len;
|
||||
for i:=len downto 1 do
|
||||
if (s[i]=' ') then dec(z) else i:=1;
|
||||
s[0]:=chr(z);
|
||||
end else
|
||||
s:=os;
|
||||
end;
|
||||
|
||||
begin
|
||||
sta:=textattr; sx:=wherex; sy:=wherey;
|
||||
os:=s;
|
||||
ins:=FALSE;
|
||||
done:=FALSE;
|
||||
infield_arrow_exited:=FALSE;
|
||||
gotoxy(x,y);
|
||||
textattr:=(infield_inp_bkgd*16)+infield_inp_fgrd;
|
||||
for i:=1 to len do write(' ');
|
||||
for i:=length(s)+1 to len do s[i]:=' ';
|
||||
gotoxy(x,y); write(s);
|
||||
p:=1; { p:=length(s)+1;}
|
||||
gocpos;
|
||||
nokeyyet:=TRUE;
|
||||
repeat
|
||||
repeat c:=readkey
|
||||
until ((not infield_only_allow_on) or
|
||||
(pos(c,infield_special_function_keys)<>0) or
|
||||
(pos(c,infield_normal_exit_keys)<>0) or
|
||||
(pos(c,infield_only_allow)<>0) or (c=#0));
|
||||
|
||||
if ((infield_normal_exit_keydefs) and
|
||||
(pos(c,infield_normal_exit_keys)<>0)) then exit_w_normal;
|
||||
|
||||
if ((infield_special_function_on) and
|
||||
(pos(c,infield_special_function_keys)<>0)) then
|
||||
infield_special_function_proc(c)
|
||||
else begin
|
||||
if (nokeyyet) then begin
|
||||
nokeyyet:=FALSE;
|
||||
if (c in [#32..#255]) then begin
|
||||
gotoxy(x,y);
|
||||
for i:=1 to len do begin write(' '); s[i]:=' '; end;
|
||||
gotoxy(x,y);
|
||||
end;
|
||||
end;
|
||||
case c of
|
||||
#0:begin
|
||||
c:=readkey;
|
||||
if ((infield_arrow_exit) and (infield_arrow_exit_typedefs) and
|
||||
(pos(c,infield_arrow_exit_types)<>0)) then exit_w_arrow
|
||||
else
|
||||
case c of
|
||||
#72,#80:if (infield_arrow_exit) then exit_w_arrow;
|
||||
#75:if (p>1) then dec(p);
|
||||
#77:if (p<len+1) then inc(p);
|
||||
#71:p:=1;
|
||||
#79:begin
|
||||
z:=1;
|
||||
for i:=len downto 2 do
|
||||
if ((s[i-1]<>' ') and (z=1)) then z:=i;
|
||||
if (s[z]=' ') then p:=z else p:=len+1;
|
||||
end;
|
||||
#82:ins:=not ins;
|
||||
#83:if (p<=len) then begin
|
||||
for i:=p to len-1 do begin
|
||||
s[i]:=s[i+1];
|
||||
write(s[i]);
|
||||
end;
|
||||
s[len]:=' '; write(' ');
|
||||
end;
|
||||
#115:if (p>1) then begin
|
||||
i:=p-1;
|
||||
while ((not (s[i-1] in infield_seperators)) or
|
||||
(s[i] in infield_seperators))
|
||||
and (i>1) do
|
||||
dec(i);
|
||||
p:=i;
|
||||
end;
|
||||
#116:if (p<=len) then begin
|
||||
i:=p+1;
|
||||
while ((not (s[i-1] in infield_seperators)) or
|
||||
(s[i] in infield_seperators))
|
||||
and (i<=len) do
|
||||
inc(i);
|
||||
p:=i;
|
||||
end;
|
||||
#117:if (p<=len) then
|
||||
for i:=p to len do begin
|
||||
s[i]:=' ';
|
||||
write(' ');
|
||||
end;
|
||||
end;
|
||||
gocpos;
|
||||
end;
|
||||
#27:begin
|
||||
s:=os;
|
||||
done:=TRUE;
|
||||
end;
|
||||
#13:begin
|
||||
done:=TRUE;
|
||||
z:=len;
|
||||
for i:=len downto 1 do
|
||||
if (s[i]=' ') then dec(z) else i:=1;
|
||||
s[0]:=chr(z);
|
||||
end;
|
||||
#8:if (p<>1) then begin
|
||||
dec(p);
|
||||
s[p]:=' ';
|
||||
gocpos; write(' '); gocpos;
|
||||
end;
|
||||
else
|
||||
if ((c in [#32..#255]) and (p<=len)) then begin
|
||||
if ((ins) and (p<>len)) then begin
|
||||
write(' ');
|
||||
for i:=len downto p+1 do s[i]:=s[i-1];
|
||||
for i:=p+1 to len do write(s[i]);
|
||||
gocpos;
|
||||
end;
|
||||
write(c);
|
||||
s[p]:=c;
|
||||
inc(p);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
until done;
|
||||
gotoxy(x,y);
|
||||
textattr:=(infield_out_bkgd*16)+infield_out_fgrd;
|
||||
for i:=1 to len do write(' ');
|
||||
gotoxy(x,y); write(s);
|
||||
gotoxy(sx,sy);
|
||||
textattr:=sta;
|
||||
|
||||
infield_only_allow_on:=FALSE;
|
||||
infield_special_function_on:=FALSE;
|
||||
infield_normal_exit_keydefs:=FALSE;
|
||||
end;
|
||||
|
||||
procedure infielde(var s:string; len:byte);
|
||||
begin
|
||||
infield1(wherex,wherey,s,len);
|
||||
end;
|
||||
|
||||
procedure infield(var s:string; len:byte);
|
||||
begin
|
||||
s:=''; infielde(s,len);
|
||||
end;
|
||||
|
||||
function l_yn:boolean;
|
||||
var c:char;
|
||||
begin
|
||||
repeat c:=upcase(readkey) until (c in ['Y','N',#13,#27]);
|
||||
if (c='Y') then begin
|
||||
l_yn:=TRUE;
|
||||
writeln('Yes');
|
||||
end else begin
|
||||
l_yn:=FALSE;
|
||||
writeln('No');
|
||||
end;
|
||||
end;
|
||||
|
||||
function l_pynq(s:string):boolean;
|
||||
begin
|
||||
textcolor(4); write(s); textcolor(11);
|
||||
l_pynq:=l_yn;
|
||||
end;
|
||||
|
||||
procedure color(fg,bg:integer);
|
||||
begin
|
||||
textcolor(fg);
|
||||
textbackground(bg);
|
||||
end;
|
||||
|
||||
procedure cwrite(s:string);
|
||||
var i:integer;
|
||||
c:char;
|
||||
lastb,lastc:boolean;
|
||||
begin
|
||||
lastb:=FALSE; lastc:=FALSE;
|
||||
for i:=1 to length(s) do begin
|
||||
c:=s[i];
|
||||
if ((lastb) or (lastc)) then begin
|
||||
if (lastb) then
|
||||
textbackground(ord(c))
|
||||
else
|
||||
if (lastc) then
|
||||
textcolor(ord(c));
|
||||
lastb:=FALSE; lastc:=FALSE;
|
||||
end else
|
||||
case c of
|
||||
#2:lastb:=TRUE;
|
||||
#3:lastc:=TRUE;
|
||||
else
|
||||
write(c);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure cwriteat(x,y:integer; s:string);
|
||||
begin
|
||||
gotoxy(x,y);
|
||||
cwrite(s);
|
||||
end;
|
||||
|
||||
function cstringlength(s:string):integer;
|
||||
var len,i:integer;
|
||||
begin
|
||||
len:=length(s); i:=1;
|
||||
while (i<=length(s)) do begin
|
||||
if ((s[i]=#2) or (s[i]=#3)) then begin dec(len,2); inc(i); end;
|
||||
inc(i);
|
||||
end;
|
||||
cstringlength:=len;
|
||||
end;
|
||||
|
||||
procedure cwritecentered(y:integer; s:string);
|
||||
begin
|
||||
cwriteat(40-(cstringlength(s) div 2),y,s);
|
||||
end;
|
||||
|
||||
{*
|
||||
* ÚÄÄÄ¿ ÉÍÍÍ» °°°°° ±±±±± ²²²²² ÛÛÛÛÛ ÖÄÄÄ· ÕÍÍ͸
|
||||
* ³ 1 ³ º 2 º ° 3 ° ± 4 ± ² 5 ² Û 6 Û º 7 º ³ 8 ³
|
||||
* ÀÄÄÄÙ ÈÍÍͼ °°°°° ±±±±± ²²²²² ÛÛÛÛÛ ÓÄÄĽ ÔÍÍ;
|
||||
*}
|
||||
procedure box(linetype,TLX,TLY,BRX,BRY:integer);
|
||||
{rcg11172000 variable j was unused.}
|
||||
{var i,j:integer;}
|
||||
var i:integer;
|
||||
TL,TR,BL,BR,hline,vline:char;
|
||||
begin
|
||||
window(1,1,80,25);
|
||||
case linetype of
|
||||
1:begin
|
||||
TL:=#218; TR:=#191; BL:=#192; BR:=#217;
|
||||
vline:=#179; hline:=#196;
|
||||
end;
|
||||
2:begin
|
||||
TL:=#201; TR:=#187; BL:=#200; BR:=#188;
|
||||
vline:=#186; hline:=#205;
|
||||
end;
|
||||
3:begin
|
||||
TL:=#176; TR:=#176; BL:=#176; BR:=#176;
|
||||
vline:=#176; hline:=#176;
|
||||
end;
|
||||
4:begin
|
||||
TL:=#177; TR:=#177; BL:=#177; BR:=#177;
|
||||
vline:=#177; hline:=#177;
|
||||
end;
|
||||
5:begin
|
||||
TL:=#178; TR:=#178; BL:=#178; BR:=#178;
|
||||
vline:=#178; hline:=#178;
|
||||
end;
|
||||
6:begin
|
||||
TL:=#219; TR:=#219; BL:=#219; BR:=#219;
|
||||
vline:=#219; hline:=#219;
|
||||
end;
|
||||
7:begin
|
||||
TL:=#214; TR:=#183; BL:=#211; BR:=#189;
|
||||
vline:=#186; hline:=#196;
|
||||
end;
|
||||
8:begin
|
||||
TL:=#213; TR:=#184; BL:=#212; BR:=#190;
|
||||
vline:=#179; hline:=#205;
|
||||
end;
|
||||
else
|
||||
begin
|
||||
TL:=#32; TR:=#32; BL:=#32; BR:=#32;
|
||||
vline:=#32; hline:=#32;
|
||||
end;
|
||||
end;
|
||||
gotoxy(TLX,TLY); write(TL);
|
||||
gotoxy(BRX,TLY); write(TR);
|
||||
gotoxy(TLX,BRY); write(BL);
|
||||
gotoxy(BRX,BRY); write(BR);
|
||||
for i:=TLX+1 to BRX-1 do begin
|
||||
gotoxy(i,TLY);
|
||||
write(hline);
|
||||
end;
|
||||
for i:=TLX+1 to BRX-1 do begin
|
||||
gotoxy(i,BRY);
|
||||
write(hline);
|
||||
end;
|
||||
for i:=TLY+1 to BRY-1 do begin
|
||||
gotoxy(TLX,i);
|
||||
write(vline);
|
||||
end;
|
||||
for i:=TLY+1 to BRY-1 do begin
|
||||
gotoxy(BRX,I);
|
||||
write(vline);
|
||||
end;
|
||||
if (linetype>0) then window(TLX+1,TLY+1,BRX-1,BRY-1)
|
||||
else window(TLX,TLY,BRX,BRY);
|
||||
end;
|
||||
|
||||
procedure checkvidseg;
|
||||
begin
|
||||
{rcg11172000 this only flies under DOS.}
|
||||
{
|
||||
if (mem[$0000:$0449]=7) then vidseg:=$B000 else vidseg:=$B800;
|
||||
ismono:=(vidseg=$B000);
|
||||
}
|
||||
end;
|
||||
|
||||
procedure savescreen(var wind:windowrec; TLX,TLY,BRX,BRY:integer);
|
||||
{rcg11172000 this only flies under DOS.}
|
||||
{
|
||||
var x,y,i:integer;
|
||||
begin
|
||||
checkvidseg;
|
||||
|
||||
wind[4000]:=TLX; wind[4001]:=TLY;
|
||||
wind[4002]:=BRX; wind[4003]:=BRY;
|
||||
|
||||
i:=0;
|
||||
for y:=TLY to BRY do
|
||||
for x:=TLX to BRX do begin
|
||||
inline($FA);
|
||||
wind[i]:=mem[vidseg:(160*(y-1)+2*(x-1))];
|
||||
wind[i+1]:=mem[vidseg:(160*(y-1)+2*(x-1))+1];
|
||||
inline($FB);
|
||||
inc(i,2);
|
||||
end;
|
||||
end;
|
||||
}
|
||||
begin
|
||||
writeln('STUB: myio.pas; savescreen()...');
|
||||
end;
|
||||
|
||||
procedure setwindow(var wind:windowrec; TLX,TLY,BRX,BRY,tcolr,bcolr,boxtype:integer);
|
||||
{rcg11172000 unused variable.}
|
||||
{var i:integer;}
|
||||
begin
|
||||
savescreen(wind,TLX,TLY,BRX,BRY); { save under window }
|
||||
window(TLX,TLY,BRX,BRY); { set window size }
|
||||
color(tcolr,bcolr); { set window colors }
|
||||
clrscr; { clear window for action }
|
||||
box(boxtype,TLX,TLY,BRX,BRY); { Set the border }
|
||||
end;
|
||||
|
||||
procedure removewindow(wind:windowrec);
|
||||
{rcg11172000 this only flies under DOS.}
|
||||
{
|
||||
var TLX,TLY,BRX,BRY,x,y,i:integer;
|
||||
begin
|
||||
checkvidseg;
|
||||
|
||||
window(1,1,80,25);
|
||||
color(14,0);
|
||||
|
||||
TLX:=wind[4000]; TLY:=wind[4001];
|
||||
BRX:=wind[4002]; BRY:=wind[4003];
|
||||
|
||||
i:=0;
|
||||
for y:=TLY to BRY do
|
||||
for x:=TLX to BRX do begin
|
||||
inline($FA);
|
||||
mem[vidseg:(160*(y-1)+2*(x-1))]:=wind[i];
|
||||
mem[vidseg:(160*(y-1)+2*(x-1))+1]:=wind[i+1];
|
||||
inline($FB);
|
||||
inc(i,2);
|
||||
end;
|
||||
end;
|
||||
}
|
||||
begin
|
||||
writeln('STUB: myio.pas; removewindow()...');
|
||||
end;
|
||||
|
||||
procedure removewindow1(wind:windowrec);
|
||||
var oldx1,oldy1,oldx2,oldy2,sx,sy,sz:byte;
|
||||
begin
|
||||
sx:=wherex; sy:=wherey; sz:=textattr;
|
||||
oldx1:=lo(windmin); oldy1:=hi(windmin);
|
||||
oldx2:=lo(windmax); oldy2:=hi(windmax);
|
||||
|
||||
removewindow(wind);
|
||||
|
||||
window(oldx1,oldy1,oldx2,oldy2);
|
||||
gotoxy(sx,sy); textattr:=sz;
|
||||
end;
|
||||
|
||||
procedure movewindow(wind:windowrec; TLX,TLY:integer);
|
||||
{rcg11172000 this only flies under DOS.}
|
||||
{
|
||||
var BRX,BRY,x,y,i:integer;
|
||||
begin
|
||||
checkvidseg;
|
||||
|
||||
window(1,1,80,25);
|
||||
color(14,0);
|
||||
|
||||
BRX:=wind[4002]; BRY:=wind[4003];
|
||||
inc(BRX,TLX-wind[4000]); inc(BRY,TLY-wind[4001]);
|
||||
|
||||
i:=0;
|
||||
for y:=TLY to BRY do
|
||||
for x:=TLX to BRX do begin
|
||||
inline($FA);
|
||||
mem[vidseg:(160*(y-1)+2*(x-1))]:=wind[i];
|
||||
mem[vidseg:(160*(y-1)+2*(x-1))+1]:=wind[i+1];
|
||||
inline($FB);
|
||||
inc(i,2);
|
||||
end;
|
||||
end;
|
||||
}
|
||||
begin
|
||||
writeln('STUB: myio.pas; movewindow()...');
|
||||
end;
|
||||
|
||||
end.
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue