/*	pashunfingaz support for chris, rms 2.0 meets decus "C" */

#include	<rms200.h>
#include	<algol68.h>

#undef	gsawatch	anything
	/* define this to check "C" memory allocation system often.
	this tests "GSA" routine we gave RMS to use as a storage allocator */

int	rmssts;		/* find RMS status from here for drop() oldi()
			   newmi_() & newmi() newi() */
int	rmsstv;		/* find o$stv here */

/*	E D I T   H I S T O R Y

??-???-??	DLE	created
27-Sep-84	DLE	invented newmi_(lun,name,reclen,lenpos)
			for use in rrmst.c. also changed newmi() to
			use newmi_().
28-sep-84	DLE	invented "rms.h" and put all the boring functions
			in there. now rms.c has in-task rms, and rrms.c
			has ex-task rms.
28-sep-84	DLE	invent rmssts kludge: stop people perving in RABs
			FABs etc.
28-sep-84	DLE	invent rmsstv kludge: still stop people perving
			in FABs etc.
28-sep-84	DLE	invent "rmsdoc.h" so lies in rms.c agree with lies in rrms.c
28-sep-84	DLE	invent wotli() to tell us what lengths we need
			in making buffers up for packets
28-sep-84	DLE	add a rmsdsp() call to do a $DISPLAY in wotli()
			to force RMS to re-compute o$tks in XB$KEY XABs.
			Otherwise we get key sizes of 0 which creams
			remote RMS: no key values ever get copied to the
			RMS task. Sigh.
 1-Oct-84	DLE	invent dummy rmscs(), rmssrv to match rrms.c
14-Jan-85	DLE	invent oldri() so easy to open files READONLY
			this stops users being pissed if programmer forgets
			freeee()
			move oldi(),oldri() to rms.h, invent xoldi() here
15-Jan-85	DLE	allow O$SHR & O$FAC parameter to xoldi()
*/

#include "rmsdoc.h"

int	rmssrv[2] = {0,0};	/* dummy server task name */

struct	rabsyn	*newmi_(lun,name,reclen,lenpos)	/* may return struct fab */
char		lun;				/* RMS channel number to use */
						/* "C" uses 1,2 & 3 !! */
char		*name;				/* ascii file name */
unsigned	reclen;				/* whole record length (bytes) */
int	*	lenpos;				/* variable-length argument list */
						/* each pair of list is 'length,position,'
						   of a key. list ends with '0' */
{
 struct	rabsyn	*r;
 struct	rmsfab	*f;
 struct	rmskey	*k;
 int	*	ip;				/* picks up extra args */
 int		keynum;				/* what key we have */
 struct rmskey *key0;				/* primary key xab */
 struct rmskey *oldk;
 int		nextlen;			/* length of next key in extra */
 int		nextposn;			/* position of next key in extra */

 int	rmscre();
 int	rmscon();

 oldk = 0;					/* in case we free some xabs */
 key0 = 0;					/* in case caller forgot keys */
 ip = lenpos;					/* consider 1st of len,pos,... */
 for	(keynum=0; keynum<8 && (nextlen=*ip++); keynum++)
	{nextposn=*ip++;
	 /* make XAB$KY for keynumber keynum, length nxtlen, position nextposn */
#ifdef gsawatch
	 $$mchk();
#endif
	 k = malloc(XB$KYL);
	 if	(!k)
		{if	(oldk)	xxxfre(oldk);	/* free what we got */
		 rmssts = ER$DME;
		 rmsstv = 042;
		 return(0);			/* return 0 : no room */
		}
	 ;
	 zero(k,XB$KYL);
	 k->o$cod	=	XB$KEY;
	 k->o$bln	=	XB$KYL;
	 k->o$dtp	=	XB$STG;
	 k->o$ref	=	keynum;
	 k->o$siz[0]	=	nextlen;
	 k->o$pos[0]	=	nextposn;
	 if	(keynum)
		{/* not 1st xab: link it to previous xab */
		 oldk->o$nxt = k;
		 k->o$flg |= XB$DUP | XB$CHG;
					/* duplicate keys OK in all
					   but primary index */
		}
	 else	/* 1st xab - remember it */
		{key0 = k;
		}
	 ;
	 oldk = k;
	}
 ;
 /* if user didn't give at least a key : let the bastard crash ! */
 if	(!key0)
	{rmssts = ER$NPK;
	 rmsstv = 042;
	 return(0);
	}
 ;

 /* here with good key XABs linked on key0 */

#ifdef gsawatch
 $$mchk();
#endif
 f = malloc(FB$BLN);
 if	(!f)
	{xxxfre(key0);
	 rmssts = ER$DME;
	 rmsstv = 042;
	 return(0);			/* return 0 if no memory */
	}
 ;
 zero(f,FB$BLN);
 f->o$xab = key0;
 f->o$bid = FB$BID;
 f->o$bln = FB$BLN;
 f->o$fna = name;
 f->o$fns = strlen(name);
 f->o$org = FB$IDX;
 f->o$rfm = FB$FIX;
 f->o$mrs = reclen;
 f->o$lch = lun;
 f->o$fac = FB$DEL | FB$UPD;
 f->o$shr = FB$WRI;
 call(rmscre,1,f);
 rmsstv = f -> o$stv;
 if	((rmssts=f->o$sts)!=SU$SUC)	return(f);
					/* return fab & xab/key */
					/* with error */

#ifdef gsawatch
 $$mchk();
#endif
 r = malloc(RB$BLN);
 if	(!r)
	{xxxfre(f);
	 rmssts = ER$DME;
	 rmsstv = 042;
	 return(0);				/* no memory */
	}
 ;
 zero(r,RB$BLN);
 r->o$fab	=	f;
 r->o$bid	=	RB$BID;
 r->o$bln	=	RB$BLN;
 r->o$rac	=	RB$KEY;
 call(rmscon,1,r);
 rmssts = r -> o$sts;
 rmsstv = r -> o$stv;
 return(r);
}

struct	rabsyn	*xoldi(lun,name,rights)		/* may return struct fab * */
char		lun;				/* RMS channel number to use */
						/* "C" uses 1,2 & 3 !! */
char		*name;				/* ascii file name */
int		rights;				/* o$shr:o$fac access masks */
{
 struct	rabsyn	*r;
 struct	rmsfab	*f;
 struct	rmskey	*k;
 struct rmskey	*oldk;
 struct rmssum	*s;
 int		numkeys;			/* number of keys */

 int	rmsdsp();
 int	rmsope();
 int	rmscon();

#ifdef gsawatch
 $$mchk();
#endif
 s = malloc(XB$SML);
 if	(!s)
	{rmssts = ER$DME;
	 rmsstv = 042;
	 return(0);			/* return 0 if no memory */
	}
 ;
 zero(s,XB$SML);
 s->o$cod = XB$SUM;
 s->o$bln = XB$SML;

#ifdef gsawatch
 $$mchk();
#endif
 f = malloc(FB$BLN);
 if	(!f)
	{xxxfre(s);
	 rmssts = ER$DME;
	 rmsstv = 042;
	 return(0);			/* return 0 if no memory */
	}
 ;
 zero(f,FB$BLN);
 f->o$xab = s;
 f->o$bid = FB$BID;
 f->o$bln = FB$BLN;
 f->o$fna = name;
 f->o$fns = strlen(name);
 f->o$lch = lun;
 f->o$fac = rights&0xFF;
 f->o$shr = rights>>8;
 call(rmsope,1,f);
 rmsstv = 042;
 if	((rmssts=f->o$sts)!=SU$SUC)	return(f);
					/* return fab & xab/sum */
					/* with error */
 /* use sum to create key xabs: then display into key xabs */
 for	(oldk=0,numkeys=s->o$nok; numkeys; numkeys--,oldk=k)
	{
#ifdef gsawatch
	 $$mchk();
#endif
	 k = malloc(XB$KYL);
	 if	(!k)
		{xxxfre(f);
		 if	(oldk)	xxxfre(oldk);
		 rmssts = ER$DME;
		 rmsstv = 042;
		 return(0);			/* return 0: no room */
		}
	 ;
	 zero(k,XB$KYL);
	 k->o$cod	=	XB$KEY;
	 k->o$bln	=	XB$KYL;
	 k->o$ref	=	numkeys-1;	/* 0-org key numbers ! */
	 k->o$nxt	=	oldk;
	 k->o$dtp	=	XB$STG;
	}
 ;
 f->o$xab = k;
 xxxfre(s);
 call(rmsdsp,1,f);
 rmsstv = 042;
 if	((rmssts=f->o$sts)!=SU$SUC)	return(f);
					/* return fab & detritus with error */
 /* have a fab & key xabs filled in */

#ifdef gsawatch
 $$mchk();
#endif
 r = malloc(RB$BLN);
 if	(!r)
	{xxxfre(f);
	 rmssts = ER$DME;
	 rmsstv = 042;
	 return(0);				/* no memory */
	}
 ;
 zero(r,RB$BLN);
 r->o$fab = f;
 r->o$bid = RB$BID;
 r->o$bln = RB$BLN;
 r->o$rac = RB$KEY;
 call(rmscon,1,r);
 rmssts = r -> o$sts;
 rmsstv = r -> o$stv;
 return(r);
}

char	*drop(r)				/* return 0 if OK,
						   return datablock if bad */
struct	rabsyn	*r;				/* the RAB to lose */
{
 struct	rmsfab	*f;

 int	rmsdis();
 int	rmsclo();

 call(rmsdis,1,r);
 rmsstv = r -> o$stv;
 if	((rmssts=r->o$sts)!=SU$SUC)	return(r);	/* fail */
 f = r->o$fab;
 gsafre(r);
 call(rmsclo,1,f);
 rmsstv = f -> o$stv;
 if	((rmssts=f->o$sts)!=SU$SUC)	return(f);	/* fail */
 xxxfre(f);
 rmssts = SU$SUC;
 rmsstv = 0;
 return(0);
}

unsigned	puti(r,buf)			/* return o$sts */
struct	rabsyn	*r;				/* the rab */
char	*buf;					/* a record */
{
 struct rmsfab	*f;

 int	rmsput();

 f = r->o$fab;
 r->o$rsz = f->o$mrs;
 r->o$rbf = buf;
 call(rmsput,1,r);
 rmsstv = r -> o$stv;
 return(rmssts = r->o$sts);
}

unsigned	getmi(r,key,buf,keynum,match)	/* return o$sts */
struct	rabsyn	*r;
char		*key;				/* full key */
char		*buf;				/* full record appears here */
unsigned	keynum;				/* number of key to use */
int		match;				/* RB$KGE or RB$KGT */
{
 struct rmsfab	*f;
 struct rmskey	*k;

 int	rmsget();

 f = r->o$fab;
 k = f->o$xab;
 while	(k && (k->o$cod!=XB$KEY || k->o$ref!=keynum) )	k = k->o$nxt;
 /* k points to the key block we need */

 r->o$rac	=	RB$KEY;
 r->o$kbf	=	key;
 r->o$krf	=	keynum;
 r->o$ksz	=	k->o$siz[0];
 r->o$ubf	=	buf;
 r->o$usz	=	f->o$mrs;
 r->o$rop	=	match;
 call(rmsget,1,r);
 rmsstv = r -> o$stv;
 return(rmssts = r->o$sts);
}

unsigned	deli(r)				/* return o$sts */
struct	rabsyn	*r;
{
 int	rmsdel();

 call(rmsdel,1,r);
 rmsstv = r -> o$stv;
 return(rmssts = r->o$sts);
}

unsigned	freeee(r)			/* return o$sts */
struct	rabsyn	*r;
{
 int	rmsfre();

 call(rmsfre,1,r);
 rmsstv = r -> o$stv;
 return(rmssts = r->o$sts);
}

unsigned	updi(r,buf)			/* return o$sts */
struct	rabsyn	*r;				/* the rab */
char	*buf;					/* a record */
{
 struct rmsfab	*f;

 int	rmsupd();

 f = r->o$fab;
 r->o$rsz = f->o$mrs;
 r->o$rbf = buf;
 call(rmsupd,1,r);
 rmsstv = r -> o$stv;
 return(rmssts = r->o$sts);
}

int	wotli(r,l)		/* return lengths data */
struct rabsyn *r;
int	l[];			/* lans */
BEGIN
struct rmsfab *f;
struct rmskey *k;
int	ref;

int	rmsdsp();

	rmsstv = 0;
/*
	rmssts = SU$SUC;
*/
	IF	(  r -> o$bid != RB$BID || r -> o$bln != RB$BLN )
	THEN	rmssts = ER$RAB;
	ELSE	f = r -> o$fab;
		call(rmsdsp,1,f);
		rmssts = f -> o$sts;
		l[1] = f -> o$mrs;
		l[0] = 0;	/* assume no keys until we see some */
		FOR	(k = f -> o$xab;	k;	k = k -> o$nxt)
		DO	IF	(k -> o$cod == XB$KEY && k -> o$bln == XB$KYL)
			THEN	/* we have a key block */
				ref = k -> o$ref;
				l[0] = max(l[0],ref+1);
				l[2+ref] = k -> o$tks;
			FI;
		OD;
	FI;
	return(rmssts);
END

rmscs()		/* dummy: choose server task */
BEGIN
END

#include "rms.h"

/* end: rms.c */
