home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 35 Internet
/
35-Internet.zip
/
ucei04.zip
/
UCEi.cmd
< prev
next >
Wrap
OS/2 REXX Batch file
|
1997-12-10
|
73KB
|
1,767 lines
/***************************************************************************/
/* This is a non-interactive script to filter mail based on a database of */
/* valid and invalid domains. The default is to reject likely invalid */
/* messages; the database can be used to add domains and addresses with */
/* specific handling (accept/reject). */
/* */
/* Files: */
/* UCEi.pdb database of addresses and domains */
/* UCEi.hdb database of headers and patterns */
/* */
/* Version dependencies: */
/* OS/2 3.0 and later with REXX and REXXUTIL.DLL */
/* LIBDB.DLL (BSD db library, included) */
/* */
/* Command line: */
/* UCEi [/TEST[=n] message */
/* Test the specified message against the header pattern and address/ */
/* domain databases; if /TEST, logging is to standard output and the */
/* result is printed instead of semaphored for MR/2 ICE; if =n is */
/* specified and n is greater than 1, all matches are printed along */
/* with the final per-header result */
/* UCEi /HLIST */
/* List entries in header pattern database */
/* UCEi /PLIST */
/* List entries in address/domain database */
/* UCEi /PADD address Y|N */
/* Add an entry to the address/domain database */
/* UCEi /HADD Y|N priority header pattern */
/* Add an entry to the header pattern database */
/* UCEi /PDELETE address */
/* Remove an entry from the address/domain database */
/* UCEi /HDELETE header [pattern] */
/* Remove the specified or all entries for the specified header from */
/* the header database */
/* UCEi /HDUMP */
/* Dump the header pattern database as a REXX script to reload it */
/* UCEi /PDUMP */
/* Dump the address/domain database as a REXX script to reload it */
/* UCEi /DUMP */
/* Dump all databases as a REXX script to reload them */
/* */
/* Brandon S. Allbery */
/* bsa@kf8nh.apk.net */
/***************************************************************************/
/* NOTICE: */
/* Any attempt to abuse the First Amendment of the U.S. Constitution by */
/* a known UCE producer in order to suppress this program or its databases */
/* will be treated as an attempt to deny me my First Amendment rights, and */
/* by extension the First Amendment rights of all Internet users. */
/***************************************************************************/
call RxFuncAdd 'SysLoadFuncs', 'REXXUTIL', 'SysLoadFuncs'
call SysLoadFuncs
call RxFuncAdd 'libDbLoadFuncs', 'LIBDB', 'libDbLoadFuncs'
call libDbLoadFuncs
VERSION = 1.4
/* Set this nonempty for a log of the script's actions */
_log = 'UCEi.log'
/*_log = ''*/
testing = 0
/* Threshold number of addresses in list for oversize trigger */
_oversize = 10 /* mail */
_ngoversize = 8 /* newsgroups */
/* Predeclared globals */
globals = '_log _myname _what _rxvsn _oversize _ngoversize _self. testing'
parse version . _rxvsn . . .
/* Allow cleanup on abort */
signal on halt name cleanup
/* main routine */
arg msg rest
parse source . _what _myname
i = lastpos('\', _myname)
if i \= 0 then _myname = substr(_myname, i + 1)
i = lastpos('.', _myname)
if i \= 0 then _myname = left(_myname, i - 1)
prdb = _myname'.PDB'
hldb = _myname'.HDB'
/* handle options */
if '/PDUMP' == msg then do
rc = dumplist(prdb)
if _what \= 'COMMAND' then return rc
exit \rc
end
if '/HDUMP' == msg then do
rc = dumphlist(hldb)
if _what \= 'COMMAND' then return rc
exit \rc
end
if '/DUMP' == msg then do
rc = dumplist(prdb)
if rc then do
say ''
rc = dumphlist(hldb)
end
if _what \= 'COMMAND' then return rc
exit \rc
end
if abbrev('/PLIST', msg, 3) then do
rc = showlist(prdb)
if _what \= 'COMMAND' then return rc
exit \rc
end
if abbrev('/HLIST', msg, 3) then do
rc = showhlist(hldb)
if _what \= 'COMMAND' then return rc
exit \rc
end
if abbrev('/PADD', msg, 3) & rest \= '' then do
rc = addprv(prdb, strip(rest, 'B'))
if _what \= 'COMMAND' then return rc
exit \rc
end
if abbrev('/PDELETE', msg, 3) & rest \= '' then do
rc = delprv(prdb, strip(rest, 'B'))
if _what \= 'COMMAND' then return rc
exit \rc
end
if abbrev('/HADD', msg, 3) & rest \= '' then do
rc = addhdr(hldb, strip(rest, 'B'))
if _what \= 'COMMAND' then return rc
exit \rc
end
if abbrev('/HDELETE', msg, 3) & rest \= '' then do
rc = delhdr(hldb, strip(rest, 'B'))
if _what \= 'COMMAND' then return rc
exit \rc
end
if abbrev('/VERSION', msg, 2) then do
if _what \= 'COMMAND' then
return VERSION
else do
say 'This is' _myname 'version' VERSION
exit 0
end
end
if left(msg, 5) = '/TEST' & (length(msg) = 5 | substr(msg, 6, 1) = '=') then do
testing = substr(msg, 6)
if testing = '' | verify(testing, '0123456789') \= 0 then testing = 1
msg = rest
rest = ''
_log = 'STDERR'
end
/* unrecognized options/arguments */
if msg = '' | left(msg, 1) = '/' | rest \= '' then do
if _what = 'COMMAND' then do
sep1 = ' '
sep2 = ''
end; else do
sep1 = '('
sep2 = ')'
end
call lineout 'STDERR', 'usage:' _myname || sep1 || 'message' || sep2
call lineout 'STDERR', 'usage:' _myname || sep1 || '/TEST message' || sep2
call lineout 'STDERR', ' ' _myname || sep1 || '/PLIST' || sep2
call lineout 'STDERR', ' ' _myname || sep1 || '/PADD addr Y|N' || sep2
call lineout 'STDERR', ' ' _myname || sep1 || '/PDELETE addr' || sep2
call lineout 'STDERR', ' ' _myname || sep1 || '/HLIST' || sep2
call lineout 'STDERR', ' ' _myname || sep1 || '/HADD Y|N priority ' ||,
'header pattern' || sep2
call lineout 'STDERR', ' ' _myname || sep1 || '/HDELETE header ' ||,
'[pattern]' || sep2
if _what \= 'COMMAND' then return 0
exit 1
end
/* obtain all local account names (implicitly valid) */
/* @@@ assumes we're run from the ICE account directory @@@ */
call SysFileTree '*.CFG', 'cf.', 'FO'
k = 0
do i = 1 to cf.0
ini = SysIni(cf.i, 'Mail', '.')
call getaddrs substr(ini, 117, pos('00'x, ini, 117) - 117), 'adx.'
/* should only be one, but who am I to enforce it? */
do j = 1 to adx.0
k = k + 1
_self.k = translate(adx.j)
end
end
_self.0 = k
drop cf. adx. i j k ini
msg = strip(msg, 'B')
rc = scan_msg(msg, prdb, hldb)
/* called as nice REXX function? be nice on return */
if _what \= 'COMMAND' then return rc
/* allow simple testing without confusing the blarg out of ICE... */
if testing > 0 then do
if rc then
say _myname':' msg 'is valid.'
else
say _myname':' msg 'is not valid.'
end; else do
/* current hacky MR/2 ICE return mechanism... */
if \rc then call lineout 'MR2_REXX.$$$', _what
end
exit rc
/***************************************************************************/
/* scan_msg(MSG, PLIST, HLIST) */
/* */
/* Check MSG for headers referencing any of the users and/or domains in */
/* the databases named by PLIST and HLIST. */
/* */
/* Arguments: */
/* MSG */
/* A file containing an RFC-compliant mail message whose headers are */
/* to be scanned. */
/* PLIST */
/* A database file containing addresses and states; assumed to be a */
/* BSD db-1.85 hash database. */
/* HLIST */
/* A database file containing header patterns; assumed to be a BSD */
/* db-1.85 btree database. */
/* */
/* Returns: */
/* 1 */
/* The message is valid: none of the listed users/domains were found. */
/* 0 */
/* An addressing header referenced one of the users/domains listed. */
/* (WARNING: this includes TO:, CC:, and BCC:, thus will match any */
/* outgoing messages as well as incoming messages.) */
/* */
/* Globals: */
/* (none) */
/* */
/* Notes: */
/* scan_hdr() does the real work; its return values are prioritized, and */
/* the last value seen at the highest priority wins. */
/* */
/* A missing "key header" is regarded as an invalid address at the lowest */
/* priority. */
/***************************************************************************/
scan_msg: procedure expose (globals); parse arg msg, plist, hlist
if stream(msg, 'C', 'QUERY EXISTS') = '' then do
call log msg': no message???'
return 1
end
/* scan even with no database, as we have some non-db-dependent checks */
stem.!openflags = 'O_RDONLY'
dbp = open_db(plist, 'H', 'stem.!')
if dbp = 0 then call log msg': error' libdb_errno 'opening' plist
stem.!flags = 'R_DUP'
hdbp = open_db(hlist, 'B', 'stem.!')
if hdbp = 0 then call log msg': error' libdb_errno 'opening' hlist
rc = stream(msg, 'C', 'OPEN')
if rc \= 'READY:' then do
call log msg': error opening message:' substr(rc, 6)
if dbp \= 0 then do
call libDbClose dbp
dbp = 0
end
if hdbp \= 0 then do
call libDbClose hdbp
hdbp = 0
end
return 1
end
/* special cases */
h_to.0 = 0
h_from.0 = 0
h_mask = 0
o_globals = globals
globals = 'h_to. h_from. h_mask dbp hdbp' globals
new = 1
line = ''
found = 0
pri = 0
do forever
l = linein(msg)
if stream(msg) \= 'READY' then leave
if l = '' then leave
hc = isheadercont(l)
nhs = \isheaderstart(l)
if nhs & new & (left(l, 5) == 'From ' | left(l, 4) == '+OK ') then do
new = 0
iterate
end
new = 0
if nhs & \hc then leave
if \new & \hc then do
fnd = scanhdr(line)
parse var fnd yn','pf
yn = (yn = 'N')
if pf > 0 | yn then call log msg':' HCHK'('fnd')' line
if pf >= pri then do
found = yn
pri = pf
end
end
if hc then do
if length(line) > 16000 then do
call log msg': enough already! header > 16000 characters'
if pri <= 1 then do
found = 1
pri = 1
end
leave
end
line = line l
end; else
line = l
end
fnd = scanhdr(line)
parse var fnd yn','pf
yn = (yn = 'N')
if pf > 0 | yn then call log msg':' HCHK'('fnd')' line
if pf >= pri then do
found = yn
pri = pf
end
call stream msg, 'C', 'CLOSE'
if dbp \= 0 then do
call libDbClose dbp
dbp = 0
end
if hdbp \= 0 then do
call libDbClose hdbp
hdbp = 0
end
globals = o_globals
/* did we see all required headers? if not, fail */
if pri <= 1 & h_mask \= 7 then do
if bitand(h_mask, 1) = 0 then call log msg': missing header FROM'
if bitand(h_mask, 2) = 0 then call log msg': missing header TO'
if bitand(h_mask, 4) = 0 then call log msg': missing header MESSAGE-ID'
found = 1
pri = 1
end
/* check h_to against h_from */
/* (this would be faster if I could guarantee ORexx on all systems...) */
if pri <= 1 then do
fnd = 0
do i = 1 to h_from.0
do j = 1 to h_to.0
if h_from.i = h_to.j then do
call log msg': header from=to' i':'h_from.i j':'h_to.j
fnd = fnd + 1
leave
end
end
end
/* allow one nonexclusive F=T: users may CC themselves */
/* @@@@ this WILL need sanity tuning... */
if fnd = 1 & h_to.0 > 1 then do
call log msg': assuming self-CC'
found = 0
end; else if fnd > 0 then do
found = 1
pri = 1
end
drop h_to. h_from.
end
call log msg': found =' found', priority =' pri'; valid =' (\found)
return \found
/***************************************************************************/
/* scanhdr(LINE) */
/* */
/* If LINE is a transport address header, return Y if it contains a user */
/* or domain listed in the database open on DBP. A priority level is also */
/* returned; the caller should continue to scan all headers and retain the */
/* result with the highest priority level. */
/* */
/* Arguments: */
/* LINE */
/* A line containing an RFC822 header. */
/* */
/* Returns: */
/* Y,n */
/* A valid address was found with priority 'n'. */
/* N,n */
/* An invalid address was found, with priority 'n'. */
/* */
/* Globals: */
/* h_from. (exported to children) */
/* A list of "from"-like addresses. */
/* h_to. (exported to children) */
/* A list of "to"-like addresses. */
/* h_mask (exported to children) */
/* A bitmask of required headers (1=From 2=To 4=Message-ID). */
/* dbp (exported to children) */
/* The address database handle. */
/* hdbp (exported to children) */
/* The general deader database handle. */
/* */
/* Notes: */
/* Priorities are numeric, with 0 as a minimum. 'Y,0' is the default */
/* return value. Three priority levels (including 0) are currently used. */
/* */
/* "From"-like and "To"-like addresses are collected into lists. After */
/* all header processing, the caller may want to examine these lists and */
/* act accordingly (e.g. same address in both is often a bogon; too long */
/* a list is also usually a warning sign). */
/* */
/* We look for To:, From:, and Message-ID: (required headers) and set the */
/* appropriate bits of h_mask. The caller should regard missing entries */
/* after the entire header has been processed as an error. */
/***************************************************************************/
scanhdr: procedure expose (globals); parse upper arg tag':'val
tag = strip(tag, 'B')
say "["tag"|"val"]"
/*
* "doit" codes:
*
* -1: NEWSGROUPS (only count "addresses")
* 0: not an address header
* 1: FROM address
* 2: TO address
* 3: TO address; don't check against TO list
* 4: Message-ID (validate domain as FROM, don't check "user ID")
* 5: TO address, but not guaranteed to have a domain
*/
select
when tag = 'FROM' then do
doit = 1
h_mask = bitor(h_mask, 1)
end
when tag = 'TO' then do
doit = 2
h_mask = bitor(h_mask, 2)
end
when tag = 'X-TO' then do
doit = 2
h_mask = bitor(h_mask, 2)
end
when tag = 'MESSAGE-ID' then do
doit = 4
h_mask = bitor(h_mask, 4)
end
/* Newsreaders usually do Cc: without To:; cheat */
when tag = 'NEWSGROUPS' then do
h_mask = bitor(h_mask, 2)
doit = -1
end
when tag = 'APPARENTLY-FROM' then doit = 1
when tag = 'APPARENTLY-TO' then do
doit = 2
h_mask = bitor(h_mask, 2)
end
when tag = 'RETURN-PATH' then doit = 1
/* see REPLY-TO --- this one is OS2-L's fault */
when tag = 'SENDER' then doit = 3
when tag = 'X-SENDER' then doit = 5
/* REPLY-TO should be a FROM code, but most mailing lists set it and TO */
/* the same --- and most spewers either omit it or make it different. */
/* They don't want to be easily traced or hit by angry responses, since */
/* responsibility for their actions is *always* to be avoided. */
when tag = 'REPLY-TO' then doit = 3
when tag = 'CC' then doit = 3
when tag = 'RESENT-FROM' then doit = 1
when tag = 'RESENT-TO' then doit = 2
when tag = 'RESENT-CC' then doit = 3
otherwise doit = 0
end
val = foldspaces(val)
found = 'Y'
pri = 0
/* check badly-formed message IDs */
xval = val
do forever
i = pos('(', xval)
if i = 0 then leave
k = i
depth = 1
do forever
j = verify(xval, '()\', 'M', k + 1)
if j = 0 then leave
if substr(xval, j, 1) = '\' then
k = j + 1
else if substr(xval, j, 1) = '(' then do
depth = depth + 1
k = j
end; else do
depth = depth - 1
if depth > 0 then
k = j
else do
if i = 0 then
xval = strip(substr(xval, j + 1), 'L')
else
xval = strip(left(xval, i - 1)) strip(substr(xval, j + 1), 'L')
leave
end
end
end
if depth \= 0 then do
call log 'unmatched parentheses!' val
leave
end
end
xval = strip(xval, 'B')
i = pos('@', xval)
if doit = 4 & (left(xval, 1) \= '<' |,
right(xval, 1) \= '>' |,
i = 0) then do
call log2 1, 'badly formed message ID' val
found = 'N'
pri = 1
end
if (doit = 4 | doit = 5) & i \= 0 then do
if verify(xval, '0123456789.>', 'N', i + 1) = 0 then do
call log2 1, 'numeric host' val
found = 'N'
pri = 1
end
end
drop xval
/*
* We now check all headers; non-address headers get scanned for address-like
* entities and passed through the address filter, *all* get passed through
* the generic filter.
*/
parse value check_gen(doit, tag, val) with nfnd','npri
if npri >= pri then do
found = nfnd
pri = npri
end
if doit = -1 then do
/* Newsgroups: --- split at commas, count */
/* (this header permits no silliness) */
cnt = 0
do forever
cnt = cnt + 1
i = pos(',', val)
if i = 0 then leave
val = substr(val, i + 1)
end
if cnt > _ngoversize & pri <= 1 then do
call log2 1, 'too many newsgroups'
found = 'N'
pri = 1
end
end; else if doit > 0 then do
call getaddrs val, 'adx.'
/* pull RFC-compliant chunks out of val and check against database */
/* shortcircuit: if it's empty, it's almost always a bogon */
if adx.0 = 0 & pri <= 1 then do
call log2 1, 'empty header' tag
found = 'N'
pri = 1
end; else do
addrs.0 = 0
cnt = 0
do idx = 1 to adx.0
cnt = cnt + 1
l = 0
do j = 1 to addrs.0
if addrs.j = adx.idx then do
if pri <= 1 then do
call log2 1, 'duplicated address' adx.idx
found = 'N'
pri = 1
end
l = 1
end
end
if \l then do
addrs.0 = addrs.0 + 1
j = addrs.0 + 1
addrs.j = adx.idx
if pri <= 1 & doit = 1 then do
do j = 1 to _self.0
if _self.j = adx.idx then do
call log2 1, 'assumed ok from my addr' adx.idx
found = 'Y'
pri = 5
leave
end
end
end
parse value check_addr(doit, tag, adx.idx) with nfnd','npri
if npri >= pri then do
found = nfnd
pri = npri
end
end
end
if pri <= 1 & cnt > _oversize then do
call log2 1, 'oversize address list' tag
pri = 1
found = 'N'
end
end
end
return found','pri
/***************************************************************************/
/* check_gen(TYPE, TAG, LINE) */
/* */
/* Check the non-address-specific header in LINE with header tag TAG for */
/* address-like "words" and check those "addresses" against the address */
/* database; check the entire line against the general header database. */
/* */
/* Arguments: */
/* TYPE */
/* The header type: 0/standard, 1-4/an address list. */
/* TAG */
/* The header tag ('FROM', 'TO', 'MESSAGE-ID', etc.) */
/* LINE */
/* The header line without the tag. */
/* */
/* Returns: */
/* Y,n */
/* The header is accepted with priority 'n'. */
/* N,n */
/* The header is rejected with priority 'n'. */
/* */
/* Globals: */
/* (none) */
/* */
/* Notes: */
/* Priorities are numeric, with 0 as a minimum. 'Y,0' is the default */
/* return value. Three priority levels (including 0) are currently used. */
/***************************************************************************/
check_gen: procedure expose (globals); parse arg doit, tag, val
found = 'Y'
pri = 0
if hdbp \= 0 then do
parse value check_mast(doit, tag, tag, val) with nfnd','npri
if npri >= pri then do
found = nfnd
pri = npri
end
parse value check_mast(doit, '*', tag, val) with nfnd','npri
if npri >= pri then do
found = nfnd
pri = npri
end
end
/* strip comments --- JUST comments, unlike the address line scanner */
l = ''
do forever
i = pos('(', val)
if i = 0 then leave
l = l || left(val, i - 1)
val = substr(val, i + 1)
depth = 1
do forever
j = verify(val, '()\', 'M')
if j = 0 then leave
if substr(val, j, 1) = ')' then do
depth = depth - 1
val = substr(val, j + 1)
if depth = 0 then leave
end; else if substr(val, j, 1) = '(' then do
depth = depth + 1
val = substr(val, j + 1)
end; else
val = substr(val, j + 2)
end
if j = 0 then leave
l = l || ' '
end
val = strip(l || val, 'T')
/*
* Pull out words: if they're address-ish, call check_addr.
*
* This one parses a bit more accurately; I should rework the address parser
* to match. Basically, quotes can be used anywhere and tokens are broken at
* spaces outside of quotes. Angle brackets *don't* quote spaces.
*/
chunk = ''
do forever
val = strip(val, 'L')
if val = '' then leave
i = verify(' ",;', val, 'M')
if i = 0 then leave
chunk = chunk || left(val, i - 1)
c = substr(val, i, 1)
val = substr(val, i + 1)
i = verify('"', val, 'M')
if c = '"' & i \= 0 then do
chunk = chunk || left(val, i - 1)
val = substr(val, i + 1)
end; else do
i = pos('@', val)
if i \= 0 | (left(chunk, 1) = '<' & right(chunk, 1) = '>') then do
parse value check_addr(doit, tag, chunk) with nfnd','npri
if npri >= pri then do
found = nfnd
pri = npri
end
end
chunk = ''
end
end
return found','pri
/***************************************************************************/
/* check_mast(TYPE, KEY, TAG, LINE) */
/* */
/* Check the specified header line against the general header database. */
/* */
/* Arguments: */
/* TYPE */
/* The header type: 0/standard, 1-4/an address list. */
/* KEY */
/* The database key to check, usually either the same as TAG or '*'. */
/* TAG */
/* The header tag ('FROM', 'TO', 'MESSAGE-ID', etc.) */
/* LINE */
/* The header line without the tag. */
/* */
/* Returns: */
/* Y,n */
/* The header is accepted with priority 'n'. */
/* N,n */
/* The header is rejected with priority 'n'. */
/* */
/* Globals: */
/* hdbp */
/* The handle for the general header database. */
/* */
/* Notes: */
/* Priorities are numeric, with 0 as a minimum. 'Y,0' is the default */
/* return value. Three priority levels (including 0) are currently used. */
/* */
/* Currently, we perform substring matches. Some future version will be */
/* able to use regular expressions. (I'm still trying to decide whether */
/* to require Perl or to try to put together a regexp module for REXX.) */
/* */
/* The database is a btree with duplicates allowed; we locate the first */
/* key match, then iterate until we run out of matching keys. */
/***************************************************************************/
check_mast: procedure expose (globals); parse arg doit, key, tag, val
found = 'Y'
pri = 0
if hdbp \= 0 then do
what = 'R_CURSOR'
keyv = key
do forever
rc = libDbSeq(hdbp, 'keyv', 'valv', what)
/* can't use "parse" because spaces are significant in pattern */
fnd = left(valv, 1)
valv = substr(valv, 3)
i = verify(valv, '0123456789')
prx = left(valv, i - 1)
pat = substr(valv, i + 1)
if rc \= 0 | keyv \= key then leave
/* NB: done this way because val may be big so search may be slow */
if prx >= pri then do
/* @@@@ future: valv may be a regexp */
if pos(pat, ' 'val' ') \= 0 then do
call log2 1, 'match hdb' tag key '{'pat'} :: {'val'}'
found = fnd
pri = prx
end
end
what = 'R_NEXT'
end
end
return found','pri
/***************************************************************************/
/* check_addr(TYPE, TAG, ADDR) */
/* */
/* Check the address-like ADDR for well-formed-ness and check against the */
/* address database. It is up to the caller to decide whether an address */
/* that is not well-formed should be rejected as a bad address (e.g. some */
/* random header contained something vaguely resembling an address). */
/* */
/* Arguments: */
/* TYPE */
/* The header type: 0/standard, 1-4/an address list. */
/* TAG */
/* The header tag ('FROM', 'TO', 'MESSAGE-ID', etc.) */
/* ADDR */
/* The address-like string to be checked. */
/* */
/* Returns: */
/* Y,n */
/* The address is accepted with priority 'n'. */
/* N,n */
/* The address is rejected with priority 'n'. */
/* */
/* Globals: */
/* dbp */
/* The address database handle. */
/* */
/* Notes: */
/* Priorities are numeric, with 0 as a minimum. 'Y,0' is the default */
/* return value. Three priority levels (including 0) are currently used. */
/***************************************************************************/
check_addr: procedure expose (globals); parse arg doit, tag, chunk
found = 'Y'
pri = 0
/* deal with route-addr; some systems are stupid */
if left(chunk, 1) = '@' then do
i = pos(':', chunk)
if i \= 0 then do
/* try user part with each route-addr host, then strip routing & pass */
j = pos('@', chunk, i)
if j \= 0 then do
user = substr(chunk, i + 1, j - i - 2)
k = 1
do while substr(chunk, k, 1) \= ':'
j = k + 1
k = pos(',', chunk, j)
if k = 0 then k = pos(':', chunk, j)
nf = check_addr(doit, tag, user'@'substr(chunk, j, k - j - 2))
parse var nf with nfnd','npri
if npri >= pri then do
found = nfnd
pri = npri
end
end
end
chunk = substr(chunk, i + 1)
end
end
i = pos('@', chunk)
if i \= 0 & pri <= 1 then do
i = pos('@', chunk, i + 1)
if i \= 0 then do
call log2 1, 'match badaddr' tag chunk
pri = 1
found = 'N'
end
end
/* sanity-check message ID */
i = lastpos('.', chunk)
j = lastpos('@', chunk)
if doit \= 5 & i \= 0 & j \= 0 & i > j then do
dom = substr(chunk, i + 1)
select
/* Three guesses who breaks the rules just to prove they can... */
when substr(chunk, j + 1) = 'MAPI.TO.RFC822' then nop
/* Numeric with brackets is okay, without isn't. */
when substr(chunk, j + 1, 1) = '[' then nop
when length(dom) = 2 then nop
when dom = 'COM' then nop
when dom = 'MIL' then nop
when dom = 'GOV' then nop
when dom = 'NET' then nop
when dom = 'ORG' then nop
when dom = 'EDU' then nop
otherwise do
call log2 1, 'invalid TLD' dom
pri = 1
found = 'N'
end
end
end
init = 1
do while chunk \= ''
i = pos('@', chunk)
if i = 0 then i = length(chunk) + 1
adr = left(chunk, i - 1)
chunk = substr(chunk, i + 1)
if init then do
user = adr
if doit \= 4 & verify(user, '0123456789', 'N') = 0 & pri <= 1 then do
call log2 1, 'match baduser' tag user'@'adr
pri = 1
found = 'N'
end
end; else do
/* special case - all numeric host part dies */
/* (actually, > 2 as prefix dies) */
j = pos('.', adr)
if j = 0 & doit \= 4 & doit \= 5 & pri <= 1 then do
call log2 1, 'match baddom' tag user'@'adr
found = 'N'
pri = 1
end
/* oops, allow x.y.z.w format */
i = verify(left(adr, i - 1), '0123456789', 'N')
if (i = 0 | i > 2) &,
verify(adr, '[0123456789.]', 'N') \= 0 & pri <= 1 then do
call log2 1, 'match badhost' tag user'@'adr
found = 'N'
pri = 1
end
/* record address for F=T check */
if doit = 1 | doit = 4 then
pfx = 'h_from.'
else if doit = 2 then
pfx = 'h_to.'
if (doit = 1 | doit = 2 | doit = 4) & user \= 'ROOT' then do
i = value(pfx'0')
i = i + 1
call value pfx || i, user'@'adr
call value pfx'0', i
end
/* check database */
if dbp \= 0 then do
yn = 'Y'
if pri <= 3 then do
if libDbGet(dbp, user'@'adr, 'fnd') = 0 then do
parse var fnd yn .
call log2 1, 'match pdb' tag user'@'adr yn
found = yn
pri = 3
end
end
if pri <= 2 then do
if libDbGet(dbp, adr, 'fnd') = 0 then do
parse var fnd yn .
call log2 1, 'match pdb' tag adr yn
found = yn
pri = 2
end
end
end
end
init = 0
end
return found','pri
/***************************************************************************/
/* foldspaces(STR) */
/* */
/* Convert runs of RFC-specification whitespace to single spaces. */
/* */
/* Arguments: */
/* STR */
/* A string. */
/* */
/* Returns: */
/* STR */
/* The string with s/[\10-\15 ]+/ /g */
/* */
/* Globals: */
/* none */
/***************************************************************************/
foldspaces: procedure expose (globals); parse arg val
l = ''
do forever
i = verify(val, '08090A0B0C0D20'x, 'M')
if i = 0 then leave
if i \= 1 then do
l = l || left(val, i - 1)
val = substr(val, i)
end
i = verify(val, '08090A0B0C0D20'x, 'N')
if i = 0 then do
val = ''
leave
end
val = substr(val, i)
l = l || ' '
end
return strip(l || val, 'B')
/***************************************************************************/
/* getaddrs(STR, STEM) */
/* */
/* Given STR containing an address list, strip trash to create a list of */
/* machine-usable addresses. */
/* */
/* Arguments: */
/* STR */
/* A string. */
/* STEM */
/* The name of a stem variable to receive the address list. */
/* */
/* Returns: */
/* (none) */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
getaddrs:
globals = arg(2) globals
call getaddrs.1 arg(1), arg(2)
return
getaddrs.1: procedure expose (globals); parse arg val!, stp!
globals = subword(globals, 2)
l! = ''
cnt! = 0
dist! = 0
do forever
i! = verify(val!, ':;"(<,', 'M')
if i! = 0 then leave
c! = substr(val!, i!, 1)
l! = l! || left(val!, i! - 1)
val! = substr(val!, i! + 1)
select
when c! = ':' then do
/* idiot systems that pass through proprietary syntax */
if l! = 'SMTP' | l! = 'INET' | l! = 'INTERNET' then
nop
else if left(val!, 1) = ':' then do
/* DECnet... same comment applies, really */
l! = l! || '::'
val! = substr(val!, 2)
end; else do
/* distribution list syntax --- we hope */
dist! = dist! + 1
l! = ''
end
end
when c! = ';' then do
if dist! > 0 then
dist! = dist! - 1
else do
call log 'invalid distribution list syntax:' arg(1)
l! = l! || c!
end
end
when c! = ',' then do
cnt! = cnt! + 1
l! = strip(l!, 'B')
/* *real* route-addr? trim if same as host */
if left(l!, 1) = '@' then do
i! = pos(':', l!)
if i! \= 0 then do
c! = substr(l!, 2, i! - 2)
d! = substr(l!, i! + 1)
i! = pos('@', d!)
if i! \= 0 then if substr(d!, i! + 1) = c! then l! = d!
end
end
if l! \= '' then call value stp! || cnt!, l!
l! = ''
end
when c! = '"' then do
do forever
j! = verify(val!, '"\', 'M')
if j! = 0 then leave
if substr(val!, j!, 1) = '"' then do
val! = substr(val!, j! + 1)
leave
end
val! = substr(val!, j! + 2)
end
if j! = 0 then leave
l! = l! || ' '
end
when c! = '<' then do
j! = pos('>', val!)
/* note we replace the collected crud... */
l! = left(val!, j! - 1)
val! = ''
end
when c! = '(' then do
depth! = 1
do forever
j! = verify(val!, '()\', 'M')
if j! = 0 then leave
if substr(val!, j!, 1) = ')' then do
depth! = depth! - 1
val! = substr(val!, j! + 1)
if depth! = 0 then leave
end; else if substr(val!, j!, 1) = '\' then
val! = substr(val!, j! + 2)
else do
val! = substr(val!, j! + 1)
depth! = depth! + 1
end
end
if j! = 0 then leave
l! = l! || ' '
end
end
end
l! = l! || val!
if l! \= '' then do
cnt! = cnt! + 1
l! = strip(l!, 'B')
/* *real* route-addr? accept only if same as host */
if left(l!, 1) = '@' then do
i! = pos(':', l!)
if i! \= 0 then do
c! = substr(l!, 2, i! - 2)
d! = substr(l!, i! + 1)
i! = pos('@', d!)
if i! \= 0 then if substr(d!, i! + 1) = c! then l! = d!
end
end
call value stp! || cnt!, l!
end
if dist! \= 0 then call log 'invalid distribution list syntax:' arg(1)
call value stp!'0', cnt!
return
/***************************************************************************/
/* isheaderstart(HDR) */
/* */
/* Return whether the line is plausibly an RFC-compliant header line. */
/* */
/* Arguments: */
/* HDR */
/* A line to be tested */
/* */
/* Returns: */
/* 1 */
/* The line looks like an RFC-compliant header. */
/* 0 */
/* The line is empty, a body line, or a line continuation. */
/* */
/* Globals: */
/* none */
/***************************************************************************/
isheaderstart: procedure expose (globals); arg ln
if ln = '' then return 0
i = pos(':', ln)
if i = 0 then return 0
j = verify(ln, '08090A0B0C0D20'x, 'M')
if j = 0 then j = length(ln)
return (j > i)
/***************************************************************************/
/* isheadercont(HDR) */
/* */
/* Return whether the line is plausibly an RFC-compliant continued header */
/* line. (See WARNING below!) */
/* */
/* Arguments: */
/* HDR */
/* A line to be tested */
/* */
/* Returns: */
/* 1 */
/* The line looks like an RFC-compliant header continuation. */
/* 0 */
/* The line is empty, a body line, or a new header line. */
/* */
/* Globals: */
/* none */
/* */
/* WARNING: None of the mail RFCs specifies a *sensible* header structure */
/* which unambiguously discriminates between header and body; if the first */
/* line of the body is indented and there is no blank line preceding it, */
/* it will be considered a header continuation and "eaten". (For this */
/* program that is likely to be harmless; but in general it is a problem.) */
/* */
/* (N.B. to mailer implementors: the current RFCs *require* a blank line */
/* between header and body to avoid the above problem. "Make it so.") */
/***************************************************************************/
isheadercont: procedure expose (globals); arg ln
return verify(left(ln, 1), '08090A0B0C0D20'x, 'M')
/***************************************************************************/
/* addprv(DB, CMDLINE) */
/* */
/* Add an entry to the private database. */
/* */
/* Arguments: */
/* DB */
/* The filename of the private database. */
/* CMDLINE */
/* The command line passed to the script, parsed as ADDR Y/N. */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
addprv: procedure expose (globals); arg db, args
if left(args, 1) \= '"' then
parse var args dom yn
else do
args = substr(args, 2)
dom = ''
do forever
i = pos('"', args)
if i = 0 then leave
dom = dom || left(args, i - 1)
args = substr(args, i)
if left(args, 2) \= '""' then leave
dom = dom || '"'
args = substr(args, 3)
end
if left(args, 1) = '"' then
yn = strip(substr(args, 2))
else do
yn = ''
dom = ''
end
end
if (yn \= 'Y' & yn \= 'N') | dom == '' then do
if _what = 'COMMAND' then do
sep1 = ' '
sep2 = ' '
sep3 = ''
end; else do
sep1 = '('
sep2 = ' '
sep3 = ')'
end
call lineout 'STDERR', 'usage:' _myname || sep1 || '/PADD' || sep2 ||,
'address Y/N' || sep3
return 0
end
dbp = open_db(db, 'H')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
if libDbPut(dbp, dom, yn date(), '') \= 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'putting key' dom
call libDbClose dbp
dbp = 0
return 0
end
call libDbClose dbp
dbp = 0
return 1
/***************************************************************************/
/* delprv(DB, CMDLINE) */
/* */
/* Remove an entry from the private database. */
/* */
/* Arguments: */
/* DB */
/* The filename of the private database. */
/* CMDLINE */
/* The command line passed to the script, parsed as ADDR. */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
delprv: procedure expose (globals); parse arg db, args
if left(args, 1) \= '"' then
dom = args
else do
args = substr(args, 2)
dom = ''
do forever
i = pos('"', args)
if i = 0 then leave
dom = dom || left(args, i - 1)
args = substr(args, i)
if left(args, 2) \= '""' then leave
dom = dom || '"'
args = substr(args, 3)
end
if left(args, 1) \= '"' then do
if _what = 'COMMAND' then do
sep1 = ' '
sep2 = ' '
sep3 = ''
end; else do
sep1 = '('
sep2 = ', '
sep3 = ')'
end
call lineout 'STDERR', 'usage:' _myname || sep1 || '/PDELETE' ||,
sep2 || 'address' || sep3
return 0
end
end
dbp = open_db(db, 'H')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
if libDbDel(dbp, dom) \= 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'deleting' dom
call lineout 'STDERR', '(was it present in the database? try /PLIST)'
call libDbClose dbp
dbp = 0
return 0
end
call libDbClose dbp
dbp = 0
return 1
/***************************************************************************/
/* addhdr(DB, CMDLINE) */
/* */
/* Add an entry to the header database. */
/* */
/* Arguments: */
/* DB */
/* The filename of the private database. */
/* CMDLINE */
/* The command line passed to the script, parsed as Y/N PRI HDR STR */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
addhdr: procedure expose (globals); arg db, yn pri tag val
err = 0
if left(val, 1) \= '"' then
dom = val
else do
val = substr(val, 2)
dom = ''
do forever
i = pos('"', val)
if i = 0 then leave
dom = dom || left(val, i - 1)
val = substr(val, i)
if left(val, 2) \= '""' then leave
dom = dom || '"'
val = substr(val, 3)
end
if val \== '"' then err = 1
end
if yn \= 'Y' & yn \= 'N' then err = 1
if tag \= '*' & verify(tag, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-') \= 0 then
err = 1
if verify(pri, '0123456789') \= 0 then err = 1
if err then do
if _what = 'COMMAND' then do
sep1 = ' '
sep2 = ' '
sep3 = ''
end; else do
sep1 = '('
sep2 = ' '
sep3 = ')'
end
call lineout 'STDERR', 'usage:' _myname || sep1 || '/HADD' || sep2 ||,
'Y/N priority header string' || sep3
return 0
end
stem.!flags = 'R_DUP'
dbp = open_db(db, 'B', 'stem.!')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
if libDbPut(dbp, tag, yn pri dom, '') \= 0 then do
call lineout 'STDERR', 'error' libdb_errno 'putting key' dom
call libDbClose dbp
dbp = 0
return 0
end
call libDbClose dbp
dbp = 0
return 1
/***************************************************************************/
/* delhdr(DB, CMDLINE) */
/* */
/* Remove an entry from the header database. */
/* */
/* Arguments: */
/* DB */
/* The filename of the header database. */
/* CMDLINE */
/* The command line passed to the script, parsed as TAG [VAL]. */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
delhdr: procedure expose (globals); parse arg db, tag val
err = 0
if tag \= '*' & verify(tag, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-') \= 0 then
err = 1
if left(val, 1) \= '"' then
dom = val
else do
val = substr(val, 2)
dom = ''
do forever
i = pos('"', val)
if i = 0 then leave
dom = dom || left(val, i - 1)
val = substr(val, i)
if left(val, 2) \= '""' then leave
dom = dom || '"'
val = substr(val, 3)
end
if val \= '"' then err = 1
end
if err then do
if _what = 'COMMAND' then do
sep1 = ' '
sep2 = ' '
sep3 = ''
end; else do
sep1 = '('
sep2 = ', '
sep3 = ')'
end
call lineout 'STDERR', 'usage:' _myname || sep1 || '/HDELETE' ||,
sep2 || 'tag string' || sep3
return 0
end
stem.!flags = 'R_DUP'
dbp = open_db(db, 'B', 'stem.!')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
/* it contains dups, so we scan. if no string, delete *all* matches. */
what = 'R_CURSOR'
keyv = tag
err = -1
do forever
rc = libDbSeq(dbp, 'keyv', 'valv', what)
if rc \= 0 | keyv \= tag then leave
/* can't use "parse" because spaces are significant in pattern */
fnd = left(valv, 1)
valv = substr(valv, 3)
i = verify(valv, '0123456789')
prx = left(valv, i - 1)
pat = substr(valv, i + 1)
if dom = '' | dom == pat then do
if err = -1 then err = 0
if libDbDel(dbp, key, 'R_CURSOR') \= 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'deleting' tag,
'pattern' pat
err = 1
end
end
what = 'R_NEXT'
end
if err = -1 then
call lineout 'STDERR', _myname': key' tag 'not found in header database'
call libDbClose dbp
dbp = 0
return (err = 0)
/***************************************************************************/
/* showlist(DB) */
/* */
/* Format and display the contents of the specified database. */
/* */
/* Arguments: */
/* DB */
/* The filename of the database to be displayed. */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
showlist: procedure expose (globals); parse arg db
stem.!openflags = 'O_RDONLY'
dbp = open_db(db, 'H', 'stem.!')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
say 'Listing of address blacklist database:' db
say ''
cnt = 0
what = 'R_FIRST'
do while libDbSeq(dbp, 'kv', 'vv', what) = 0
say left(kv, 40) || vv
cnt = cnt + 1
what = 'R_NEXT'
end
call libDbClose dbp
dbp = 0
say ''
say cnt 'entries in database.'
return 1
/***************************************************************************/
/* showhlist(DB) */
/* */
/* Format and display the contents of the specified database. */
/* */
/* Arguments: */
/* DB */
/* The filename of the database to be displayed. */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
showhlist: procedure expose (globals); parse arg db
stem.!openflags = 'O_RDONLY'
stem.!flags = 'R_DUP'
dbp = open_db(db, 'B', 'stem.!')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
say 'Listing of header blacklist database:' db
say ''
cnt = 0
what = 'R_FIRST'
do while libDbSeq(dbp, 'kv', 'vv', what) = 0
say left(kv, 40) || vv
cnt = cnt + 1
what = 'R_NEXT'
end
call libDbClose dbp
dbp = 0
say ''
say cnt 'entries in database.'
return 1
/***************************************************************************/
/* dumplist(DB) */
/* */
/* Dump the contents of the specified database as reload commands. */
/* */
/* Arguments: */
/* DB */
/* The filename of the database to be dumped. */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
dumplist: procedure expose (globals); parse arg db
stem.!openflags = 'O_RDONLY'
dbp = open_db(db, 'H', 'stem.!')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
say '/* Reload address blacklist database:' db '*/'
say ''
what = 'R_FIRST'
do while libDbSeq(dbp, 'kv', 'vv', what) = 0
say 'CALL' _myname "'/PADD'" qq(kv) left(vv, 1)
what = 'R_NEXT'
end
call libDbClose dbp
dbp = 0
return 1
/***************************************************************************/
/* dumphlist(DB) */
/* */
/* Dump the contents of the specified database as reload commands. */
/* */
/* Arguments: */
/* DB */
/* The filename of the database to be dumped. */
/* */
/* Returns: */
/* 1 */
/* The command was successful. */
/* 0 */
/* The command failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
dumphlist: procedure expose (globals); parse arg db
stem.!openflags = 'O_RDONLY'
stem.!flags = 'R_DUP'
dbp = open_db(db, 'B', 'stem.!')
if dbp = 0 then do
call lineout 'STDERR', _myname': error' libdb_errno 'opening' db
return 0
end
say '/* Reload header blacklist database:' db '*/'
say ''
what = 'R_FIRST'
do while libDbSeq(dbp, 'kv', 'vv', what) = 0
/* can't use "parse" because spaces are significant in pattern */
fnd = left(vv, 1)
vv = substr(vv, 3)
i = verify(vv, '0123456789')
prx = left(vv, i - 1)
pat = substr(vv, i + 1)
say 'CALL' _myname "'/HADD'" fnd prx sq(kv) qq(pat)
what = 'R_NEXT'
end
call libDbClose dbp
dbp = 0
return 1
/***************************************************************************/
/* qq(STRING) */
/* */
/* Doublequote the specified string, doubling internal quotes as needed. */
/* (More: it then single-quotes the result.) */
/* */
/* Arguments: */
/* STRING */
/* The string to quote. */
/* */
/* Returns: */
/* STRING */
/* The quoted string. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
qq: procedure expose (globals); parse arg str
/* this is faster in Object Rexx... */
/* return '"' || changestr('"', str, '""') || '"' */
res = '"'
do forever
i = pos('"', str)
if i = 0 then leave
res = res || left(str, i) || '"'
str = substr(str, i + 1)
end
return sq(res || str || '"')
/***************************************************************************/
/* sq(STRING) */
/* */
/* Singlequote the specified string, doubling internal quotes as needed. */
/* */
/* Arguments: */
/* STRING */
/* The string to quote. */
/* */
/* Returns: */
/* STRING */
/* The quoted string. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
sq: procedure expose (globals); parse arg str
res = "'"
do forever
i = pos("'", str)
if i = 0 then leave
res = res || left(str, i) || "'"
str = substr(str, i + 1)
end
return res || str || "'"
/***************************************************************************/
/* open_db(DB, TYPE[, MODE]) */
/* */
/* Open a BSD db-1.85 database, retrying if it is locked. */
/* */
/* Arguments: (forwarded to libDbOpen without inspection or modification) */
/* DB */
/* The database file to be opened. */
/* TYPE */
/* The type of database: 'BTREE', 'HASH', 'RECNO' */
/* MODE */
/* An optional stem variable containing OS and db-related modes */
/* */
/* Returns: */
/* DBP */
/* A database identifier, or 0 if the open failed. */
/* */
/* Globals: */
/* (none) */
/***************************************************************************/
open_db: procedure expose (globals)
do forever
if arg(3, 'E') then
dbp = libDbOpen(arg(1), arg(2), arg(3))
else
dbp = libDbOpen(arg(1), arg(2))
if dbp \= 0 then return dbp
if libdb_errno \= 24 then return 0
call SysSleep 1
end
/* NOTREACHED */
/***************************************************************************/
/* log(STRING) */
/* */
/* Record the specified string in the logfile, with date/time stamp. If */
/* the log file name is '', no log is kept. */
/* */
/* Arguments: */
/* STRING */
/* The string to record in the logfile. Additional arguments are not */
/* recognized at the present time. */
/* */
/* Returns: */
/* (none) */
/* */
/* Globals: */
/* _log */
/* The name of the log file; if '', logging is not performed. */
/***************************************************************************/
log: procedure expose (globals); parse arg msg
if _log = '' then return
/* ORexx appends, CRexx overwrites... sigh */
/* (can't do this unconditionally because SEEK is incompatible between them) */
if left(log, 3) \= 'STD' & _rxvsn < 6 then do
call stream _log, 'C', 'OPEN'
call stream _log, 'C', 'SEEK <0'
end
call lineout _log, msg
if left(log, 3) \= 'STD' then call stream _log, 'C', 'CLOSE'
return
/* used for debugging */
log2: procedure expose (globals); parse arg level, msg
/*if testing > level then*/ call log msg
return
/***************************************************************************/
/* SIGNAL NAME cleanup */
/* */
/* Closes the socket opened by getpage(). */
/***************************************************************************/
cleanup:
if symbol('dbp') = 'VAR' & dbp \= 0 then do
signal on syntax name cleanup.2
call libDbClose dbp
end
cleanup.2:
if symbol('hdbp') = 'VAR' & hdbp \= 0 then do
signal on syntax name cleanup.3
call libDbClose hdbp
end
cleanup.3:
exit 1
