PDP-10.its/src/bawden/lsrdmp.33

; -*- Midas -*-

title LSRDMP - Dump the LSR1 database

a=:1
b=:2
c=:3
d=:4
e=:5
t=:6
tt=:7
x=:10
y=:11
z=:12

p=:17

..bch==:0,,-1
chdsko==:2
chlsri==:3
chhsti==:4

%fr==:0,,525252
%fl==:1,,525252
%flat==: 200000
%flctl==:100000
%flodd==:040000

call=:pushj p,
return=:popj p,
save==:push p,
rest==:pop p,
flose=:.lose %lsfil
slose=:.lose %lssys
pause=:.break 16,100000

quit=:call .
$quit:	skipe debug
	 pause
	.logout 1,

define bltdup org,len
	move tt,[<org>,,<org>+1]
	blt tt,<org>+<len>-1
termin

define syscall name,args
	.call [setz ? .1stwd sixbit /name/ ? args(400000)]
termin

define conc foo,bar
foo!bar!termin

; JSP T,LOSE is like .LOSE %LSSYS(TT) or SLOSE (TT)
lose:	syscall lose,[movei %lssys(tt) ? movei -2(t)]
	 slose

popj1:	aos (p)
cpopj:	return

lsrtns"$$ulnm==:0
lsrtns"$$ulnp==:0
lsrtns"$$unam==:0
lsrtns"$$ovly==:0
.insrt dsk:syseng;lsrtns >

netwrk"$$hstmap==:1
netwrk"$$hostnm==:1
netwrk"$$symlook==:1
netwrk"$$look==:1
netwrk"$$chaos==:1
netwrk"$$tcp==:1
.insrt dsk:syseng;netwrk >

.insrt dsk:syseng;format >

outstr:	syscall siot,[movei chdsko ? a ? b]
	 slose
	return

define format &string&,args
	call [
	call $format
.zzz.==-1
irp arg,,[args]
	save arg
.zzz.==.irpcnt
termin
	hrroi a,[ascii string]
	movei b,.length string
	movni c,.zzz.+1
	jrst format"format]
termin

$forma:	save a
	save b
	save c
	call @-3(p)
	rest c
	rest b
	rest a
	rest (p)
	return

.vector pdl(lpdl==:100.)

usrvar:	sixbit /OPTION/	? tlo %opint\%opopc
	sixbit /MASK/	? move [%pipdl]
lusrvar==:.-usrvar

go:	move p,[-lpdl,,pdl-1]
	.open chdsko,[.uao,,'dsk ? sixbit /LSRDMP/ ? sixbit /OUTPUT/]
	 slose
	move t,[-lusrvar,,usrvar]
	syscall usrvar,[movei %jself ? move t]
	 slose
	movei a,chlsri
	move b,[-nfpage,,ffpage]
	call lsrtns"lsrmap
	 .lose
	movei a,(b)
	movei b,chhsti
	call hstini
	skipg b,lsrtns"lsradr
	 .lose
	add b,lsrtns"hdrdta(b)
	jrst gogo

.scalar entry

next:	move b,entry
	hlrz t,(b)
	addi b,(t)
gogo:	setcm t,(b)
	trce t,-1
	 .lose
	aoje t,done
	movem b,entry

.scalar group
.scalar relation
lname==:[440700,,uname]
.scalar fname
.scalar fhost
.scalar fdom
.scalar fhostn
len==:40
.vector uname(len)
.vector neta(len)
.vector hsta(100.)

define get item
	movei a,lsrtns"i$!item
	call getitm
termin

define csjne text,loc,exit
irpc ch,,[text]
	ildb tt,loc
	caie tt,"ch
	 jrst exit
termin
	ildb tt,loc
	jumpn tt,exit
termin

	get uname
	 .lose			; UNAME is empty string?
	move d,[440700,,uname]
	call copy
	tlne %flodd
	 jrst next		; Only UNAMEs with letters and digits

	get neta
	 jrst next
	move d,[440700,,neta]
	call copy
	tlne %flctl
	 jrst next		; No random characters in network address
	tlne %flat
	 jrst neta1
	move t,lname
	move tt,[440700,,neta]
	jrst neta3

neta1:	setzi t,
	idpb t,atptr
	move t,[440700,,neta]
	move tt,atptr
neta3:	movem t,fname
	movem tt,fhost
	call getdom

	move a,fhost
	call netwrk"hstlook
	 jrst neta6
	movem a,fhostn
	movsi x,-nhosts
	came a,haddr(x)
	 aobjn x,.-1
	jumpl x,neta7
; FHOST found in host table:
	skipe fdom
	 jrst neta9		; Domain name is fine
	move b,fhostn
	call netwrk"hstsrc
	 .lose
	hrli a,440700
	move d,[440700,,hsta]
	movem d,fhost
	call copyz
	jrst neta9

; FHOST not in host table:
neta6:	setzm fhostn
	skipn a,fdom
	 jrst next		; Flush non-domain name not in host table.
	csjne arpa,a,neta9	; Also .ARPA name not in host table.
	jrst next

; FHOST gets special treatment:
neta7:	move x,hmail(x)
	skipn t,hname(x)
	 jrst next		; Flush
	movem t,fhost		; Canonicalize
	caie x,qlcs-haddr
	 jrst neta9
; FHOST -is- lcs.mit.edu
	skipe localp
	 jrst neta10
	jrst next

; FHOST is -not- lcs.mit.edu
neta9:	skipe localp
	 jrst next
neta10:

	get grp
	 skipa x,[40]
	  ildb x,a
	get rel
	 skipa y,[40]
	  ildb y,a
	movem x,group
	movem y,relation

	get name
	 move a,[440700,,[asciz "(unknown)"]]

	format "#  ~C~C	~A~%~A:	~A@~A~@
		",[group,relation,a,lname,fname,fhost]
	jrst next

done:	pause
	quit

; CALL GETDOM:  Set FDOM from FHOST
getdom:	move z,fhost
gtdm1:	ildb t,z
	caie t,".
	 jumpn t,gtdm1
	skipn t
	 setzi z,
	movem z,fdom
	return

hstini:	call netwrk"hstmap
	 .lose
	movsi x,-nhosts
hstin1:	move a,hname(x)
	call netwrk"hstlook
	 .lose
	movem a,haddr(x)
	aobjn x,hstin1
	return

define hstirp body
define defhst short,long,mail
body
termin
defhst db,db,db
termin

localp:	0			; non-0 => output local entries instead.

haddr::
hstirp [ q!short: 0 ]
nhosts==:.-haddr
qflush:	0

hname::
hstirp [ 440700,,[asciz "long"]]
nhosts==:.-hname
	0

hmail::
hstirp [ q!mail-haddr ]
nhosts==:.-hmail

; CALL GETITM:  Get an item from an entry
; A (arg):  Item number
; A (val):  Byte pointer to string or 0
; C (val):  Length
getitm:	save b
	move b,entry
	call lsrtns"lsritm
	 jrst get0
	call trim
	jumpe c,get0
	rest b
	aos (p)
	return

get0:	setzb a,c
	rest b
	return

; CALL TRIM:  Clean up string in A
; Trims off leading and trailing whitespace and computes length.
; A (a/v):  Byte pointer (updated)
; C (val):  Computed length
trim:	skipa z,a
trim1:	 move a,z
	ildb t,z
	caie t,40
	 cain t,^I
	  jrst trim1
	setzb c,y
	aoja y,trim3
	
trim2:	ildb t,z
	caie t,40
	 cain t,^I
	  aoja y,trim2
trim3:	jumpe t,cpopj
	move c,y
	aoja y,trim2

.scalar atptr			; BP to "@hostname..."
.scalar atlen			; length of "@hostname..."

; CALL COPY:  Copy and lowercaseify string
; Also set %FLAT, %FLCTL, %FLODD, ATPTR and ATLEN
; A (a/v):  Source BP
; C (a/v):  Count
; D (arg):  Destination BP
copy:	move x,c
	move y,a
	tlz %flat\%flctl\%flodd
	caile x,<len*5>-1
	 .lose
	jumple x,copy0
copy1:	ildb t,y
	cain t,"@
	 jrst copyat
	cail t,"A
	 caile t,"Z
	  caia
	   movei t,"a-"A(t)
	caile t,40
	 cail t,177
	  tlo %flctl
	cail t,"0
	 caile t,"9
	  cail t,"a
	   caile t,"z
	    tlo %flodd
copy3:	idpb t,d
	sojg x,copy1
copy0:	setzi t,
	idpb t,d
	return

copyat:	tlo %flat
	movem d,atptr
	movem x,atlen
	jrst copy3

; CALL COPYZ:  Copy ASCIZ string and lower case
; A (arg):  Source
; D (arg):  Destination
copyz:	ildb t,a
	cail t,"A
	 caile t,"Z
	  caia
	   movei t,"a-"A(t)
	idpb t,d
	jumpn t,copyz
	return

intsv0==:t			; Save T
intsv9==:z			; Through Z
intsvn==:intsv9+1-intsv0

intctl==:400000+intsv0_6+intsvn	; control bits
intpc==:-<3+intsvn>		; INTPC(P) is PC before interrupt.
intdf1==:intpc-2		; INTDF1(P) is .DF1 before interrupt.
intdf2==:intpc-1		; INTDF2(P) is .DF2 before interrupt.
intrq1==:intpc-4		; INTRQ1(P) are first word bits.
intrq2==:intpc-3		; INTRQ2(P) are second word bits.
intac0==:intpc+1-intsv0		; INTAC0+C(P) is C before interrupt.

tsint:
loc 42
	-ltsint,,tsint
loc tsint
	intctl,,p
ltsint==:.-tsint

dismis:	setz ? sixbit /DISMIS/ ? movsi intctl ? setz p

cnst0:
constants
repeat <.-cnst0+77>/100, conc cnst,\.rpcnt,=:cnst0+.rpcnt*100

variables

debug:	0

patch::
pat:	block 100.
epatch:	-1			; Make memory exist, end of patch area

ffaddr:
ffpage==:<ffaddr+1777>_-12
nfpage==:400-ffpage

end go