/*
   Local changes for VM/ESA 1.2.1 (REXX370 Vers. 4.00) or greater
    -> The variable "b" in the routine "NICE" (around line 802-815)
       was changed to "bb" because of the following change:
 
 (c) Copyright IBM Corporation 1990, 1993
 
"462E   Error 15 running fn ft, line nn:  Invalid hexadecimal or binary
        string
 
 Explanation:  Binary strings were new in VM/ESA Release 2, and the
 language processor may now be considering the string in your statement
 to be binary when that was not your intention.
 
 ...   Or you may have put the 1-character symbol X, x, B, or b (the name
 of the variable X or B, respectively) after a literal string, when the
 string is not intended as a hexadecimal or binary specification."
*/
 
/* rxIRC
 * Internet Relay Chat client program for VM/CMS systems
 * written by Carl 'LynX' v. Loesch (loesch@informatik.uni-oldenburg.de)
 * created by Lynx (244661 at DOLUNI1) on Thursday, 14 Feb 1991
 * Credits for suggestions, code contribution, miscellaneous help go to:
 *    Jose Maria Blasco, Doug Sewell, Martin Ahlborn, Jim McMaster,
 *    Scott Maxell, Juan Courcoul, Rob Blais, Mike Letourneau, Grant Pair
 *    (in historical order mostly).   Thank y'all very much!
 *
 * requires RXSOCKET MODULE version 2 by Arty Ecock (eckcu@cunyvm.bitnet)
 *
 * Copyright (C)1991,2,3 by Lynx & CvO University Oldenburg, Germany
 * You may freely use this software at your own risk.
 * No distribution of modified copies permitted, pls send changes to me.
 *
 * By the way, this is _not_ the source code of rxIRC. There exists a
 * special file IRC PREXX which when run through a preprocessor produces
 * the actual RXIRC EXEC. That file is commented. This one is not.
 */ vers='2.0.1'; trace 'O'
 address "COMMAND"; signal on HALT; "VMFCLEAR"
 cmds='AWAY AWAIT ADMIN CHANNEL CONNECT DEOP DIE HASH INFO ISON JOIN KICK',
   'KILL LIST LINKS LUSERS MODE MAIL MOTD NAMES NICK NOTICE NOTE OPER PASS',
   'PART REHASH RESTART QUIT SERVICE SQUIT SUMMON STATS TOPIC TIME TRACE',
   'USERS USERHOST VOICE WHOWAS WALLOPS WALL XTRA'
 log=0; query=; ignore=; lastjoin=; lastsender=; onoff.1="on"; onoff.0="off"
 invitation=; away=; ll.=; curll=1; logevent=0; target=time('R')
 v.=; al.=; varnames=; aliasnames=; cmdchar=; userinfo=; sourcing=0
 have_rxwt=0; who_empty=0; catmode=0; catlist=; abortsource=0; skiplines=0
 "EXECIO * CP (STEM PF. STRING QUERY PF"
 do i=1 to pf.0
  a=word(pf.i,2)
  if a/='UNDEFINED' & a/='RETRIEVE' then,
    "CP SET" subword(pf.i,1,2) '!'subword(pf.i,3)
 end
 "EXECIO * CP (STEM QT. STRING QUERY TERM"
 "CP TERM LINEND OFF"
 "CP TERM CHARDEL OFF"
 "CP TERM LINESIZE 130"
 sock=; buffer=; alphalo=xrange('a','z'); alphahi=xrange('A','Z')
 lf='25'x; cr='0d'x; msa='01'x; rev='02'x; beep='2f'x; undl='32'x
 bold='1f'x; hi='1de8'x; lo='1d60'x; yo='1d44'x
 nice.=""; u@n.=; via.=;
 realname=; servername=;
 ignore_reply = "Your messages are not being received."
 "IDENTIFY (LIFO"; pull me . mynode . rscs a .
 logfile=translate(a,'_','/') "IRCLOG A0"
 writelog="EXECIO 1 DISKW" logfile "(STRI"
 'STATE RXSOCKET MODULE *'
 if rc=0 then do
  parse value SOCKET('version') with . . rc .
  if rc >= 2.0 then rc=0
  else rc=28
 end
 if rc/=0 then call BYE "RXSOCKET version 2 required"
 do 3
  parse value SOCKET('INITIALIZE', 'rxIRC', 1) with rc . etc
  if rc=2004 then do
   say '<cleaning up a zombie rxsocket nucext>'
   'NUCXDROP RXSOCKET'
  end
  else leave
 end
 if rc/=0 then call BYE "initialize error:" etc
 parse value SOCKET('GETHOSTNAME') with . hostname
 parse value SOCKET('GETDOMAINNAME') with . domain
 'REXXWAIT TEST'
 select
  when rc=0 then nop
  when rc=1 then do
   'REXXWAIT LOAD'
   if rc/=0 then call BYE "REXXWAIT can't be loaded"
  end
  otherwise call BYE "REXXWAIT MODULE required"
 end
 have_rxwt=1
 'IMMCMD SET HI'
 "NAMEF :NICK RXIRC :SERVER :PORT :LOGGING :QUIET_IGNORE :SHOW_TIME ",
   ":BOLD_CHAR :BEEP_CHAR :LOUD_BEEPS :SHOW_NUMBERS :LIST_ALL :BROWSER",
   "(LIFO FILE RXIRC"
 if rc/=0 then call BYE "missing or unreadable RXIRC NAMES file"
 pull viewcmd; pull def_listall; pull def_numb; pull def_loud
 parse pull beepch; parse pull boldch; parse pull showtime; pull def_quiet
 pull def_log; parse pull def_port; parse pull def_server
 if viewcmd='' then call BYE 'no ":browser" tag defined in RXIRC NAMES'
 if beepch='' then beepch=d2c(0)
 if boldch='' then boldch=d2c(0)
 "GLOBALV SELECT CENV GET IRCNICK IRCSERVER IRCNAME IRCPORT"
 
 "NAMEFIND :USERID" me ":NICK :NAME :MOTTO :CMDCHAR :IRCNICK :IRCNAME (LIFO"
 if rc=0 then do
  parse pull name; parse pull nick
  if ircnick="" then ircnick=nick
  if ircname="" then ircname=name
  parse pull cmdchar; parse pull userinfo
  parse pull realname; parse pull nick
  if ircnick="" then ircnick=nick
  if ircname="" then ircname=realname
 end
 
 parse arg nick server name '('o; upper o
 if nick/='' then ircnick = nick
 if ircnick='' then ircnick=me
 capnick = translate(ircnick)
 if server/='' then ircserver=server
 else if ircserver='' then ircserver=def_server
 if name/='' then ircname = name
 if ircname='' then ircname=me "at" mynode".bitnet"
 if cmdchar="" then cmdchar="/"
 do while o/=""
  parse var o opt o
  select
   when abbrev("PORT", opt, 1) then parse var o ircport o
   when abbrev("LIST_ALL", opt, 2) then parse var o def_listall o
   when abbrev("LOGGING", opt, 1) then parse var o def_log o
   when abbrev("LOUD_BEEPS", opt, 3) then parse var o def_loud o
   when abbrev("NUMBERS", opt, 1) then parse var o def_numb o
   when abbrev("QUIET_IGNORE", opt, 1) then parse var o def_quiet o
   otherwise call BYE "unknown option" opt
  end
 end
 if ircport='' then ircport=def_port
 if def_listall="ON" then listall=1; else listall=0
 if def_log="ON" then log=1; else log=0
 if def_loud="ON" then loud=1; else loud=0
 if def_numb="ON" then numb=1; else numb=0
 if def_quiet="ON" then quiet=1; else quiet=0
 if log then writelog "IRC Session started on" date() "at" time()
 if datatype(left(ircnick,1))='NUM' then ircnick='u'ircnick
 if ^datatype(showtime,'w') then showtime=80
 if userinfo="" then userinfo="- no info given by user -"
 
 parse value RESETVALUE('ALL') with rc .
 if rc/=0 then call BYE "problem w/RESETVALUE"
 parse value SETVALUE('TIME ==:=0:00') with rc .
 if rc/=0 then call BYE "problem w/SETVALUE TIME"
 parse value SETVALUE('MSG IUCV') with rc .
 if rc/=0 then call BYE "problem w/SETVALUE MSG IUCV"
 call S "rxIRC"hi||vers||yo"- You are" ircnick "("ircname")"
 call S "Logging is" onoff.log"; Audible bells are",
   onoff.loud"; Quiet ignore is" onoff.quiet
 if showtime=80 then say "Time display is off"
 else say "Time is displayed every" showtime "minutes"
 call CONNECT ircserver
 call S copies("-",79)lo
 do forever
  "IMMCMD STATUS HI"
  if rc/=0 then call S,
    'Sorry, "hi" is a system reserved word. Try an other operating system.'
  parse value WAIT('TIME','CONS','MSG','SOCKET READ' sock) with rc type data
  select
   when rc/=0 then call BYE "REXXWAIT returning code" rc
   when type='SOCKET' then do
    parse value SOCKET('READ', sock) with rc . data
    if rc=54 then call BYE
    if rc/=0 then call BYE 'socket read error' rc
    buffer = buffer || data
    do forever
     if index(buffer, lf)=0 then leave
     parse var buffer in (lf) buffer
     call OUT PARSE(strip(in,,cr))
    end
   end
   when type = 'CONS' then if data/='' then do
    rc=time('R')
    call EDIT data
    curll=curll+1; ll.curll=hi||data||lo; k=curll-50; ll.k=;
    if log then writelog ' 'data
   end
   when type = 'MSG' then do
    parse var data . . no'('id'): 'data
    if id='' then id='RSCS'
    origin=id'@'no
    ni=NICE(origin)
    if FINDM(ignore,origin) | FINDM(ignore,ni) then do
     if ^quiet & left(data,1)/='*' then call TELL origin '*' ignore_reply
    end; else do
     call OUT hi||ni':'lo||data
     if away/='' & left(data,1)/='*' then call TELL origin '* away:' away
    end
   end
   when type = 'TIME' then do
    parse var data . hh':'mm':' .
    if datatype(mm/showtime,'w') then call S 'It is now' hh':'mm
    'EXECIO 1 CP(VAR A STR Q' me
    parse var a . '-' a .
    if a='DSC' then do
     data='virtual machine runs disconnected'
     call SEND 'QUIT :'data
     call BYE data
    end
   end
   otherwise
   call S 'Unexpected event:' type data
  end
 end
 call BYE "a rexx oddity"
 
PARSE:
 parse arg a
 if loud & pos(beep,a)/=0 then "BEEP"
 b=; a=translate(a,"%"||beepch||"_",rev||beep||undl)
 i=1; j=0; do forever; i=index(a,bold,i)
  if i=0 then leave
  if j=0 then a=insert(hi,a,i)
  else a=insert(lo,a,i)
  a=delstr(a,i,1)
  j=1-j
 end
 if j=1 then a=a||lo
 if left(a,1)=':' then do
  parse var a ':'s m e f ':'g
  parse var s s'!'sad
 end
 else do; s=''; parse var a m e f ':'g; end
 f=strip(f)
 logevent = 1
 select
  when m='CHANNEL' then if e="0"
  then b='***' s 'leaves this channel'
  else b='***' s 'joins this channel'
  when m='INVITE' then do
   f=strip(word(f g,1))
   invitation = f
   lastsender = s
   b='***' s '('sad') invites you to channel' f; end
  when m='JOIN' then do
   e=strip(word(e g,1))
   b='***' s '('sad') joins channel' e
   if s=ircnick then target=translate(e)
   else lastjoin=s
  end
  when m='KICK' then b='***' s 'kicks' f 'off channel' e
  when m='KILL' then b='You were killed by' s subword(g,2)
  when m='MODE' then b='Mode change:' s 'sets' f 'on' e
  when m='MSG' then b='<'s'>' g
  when m='NICK' then b='***' s 'is now known as' e||g
  when m='NOTICE' then select
   when s='' | s=servername then do
    if word(g,1)="***" then b=subword(g,2)
    else b=g
    a=; parse var b 'Your host is 'g'['a .
    if a/='' then servername=g
   end
   when translate(e)=capnick then do
    if FINDM(ignore,s) | FINDM(ignore,sad) then do
     return ''; end
    else do; b='-'s'-' g
     lastsender=s
    end
   end
   otherwise b='-'s':'e'-' g; end
  when m='PART' then b='***' s 'parts channel' e
  when m='PING' then call SEND("PONG :"ircnick)
  when m='PRIVMSG' then select
   when translate(e)=capnick then do
    if FINDM(ignore,s) | FINDM(ignore,sad) then do
     if ^quiet then call SEND('NOTICE' s ':'ignore_reply)
     return ''; end
    else do
     if CTCP(1 g) then b='*'s'*' g
     lastsender=s
    end
   end
   when translate(e)=target then if CTCP(0 g) then b='<'s'>' g
   otherwise if CTCP(0 g) then b='<'s':'e'>' g; end
  when m='QUIT' then b='Signoff by' s '('g')'
  when m='TOPIC' then b='***' s 'sets the topic to:' g
  when m='WALLOPS' then b='Wallops from' s':' g
  when m='WALL' then b='Broadcast from' s':' g
  when m='221' then b='Your mode is' g
  when m='301' then b=f 'is away:' g
  when m='311' then do
   parse var f ni ui no .
   b=ni 'is' ui'@'no '('g')'
  end
  when m='314' then do; parse var f ni ui no .
   b=ni 'was' ui'@'no '('g')'; end
  when m='312' then b='via' word(f,2) '('g')'
  when m='315' then if who_empty then call S 'No matches for /who'
  when m='319' then b='on channels:' g
  when m='317' then b='and has been idle' word(f,2) 'seconds'
  when m='322' then do
   parse var f ch n .
   if ch/='*' & substr(ch,2,1)/='27'x then do
    if catmode then do; if n>4 then catlist=ch catlist; end
    else if listall | n>7 then call OUT left(ch,13) left(n,4)g
  end; end
  when m='323' then do
   if catmode then do
   call OUT 'Channels:' catlist; catlist=; catmode=0; end; end
  when m='324' then b='The mode on channel' word(f,1) 'is' word(f,2)
  when m='332' then b='The topic is:' g
  when m='341' then b='Inviting' word(f,1) 'to channel' word(f,2)
  when m='352' then do
   parse var f ch us no . ni st .
   if st="S" then return ''
   who_empty=0; n=subword(g,2)
   do forever; a=64-(length(n)+length(us)+length(no))
    if (length(no)+a > 13) then leave
    n=subword(n, 1, words(n)-1)'..'; end
   if (a < 0) then k=hi||n||lo||us"@*"right(no,length(no)+a-1)
   else if (ch/='*' & a>length(ch)) then
     k=lo||ch||hi||n||lo||copies(' ',a-length(ch)-1)us"@"no
   else k=hi||n||lo||copies(' ',a)us"@"no
   call S left(st,3)yo||left(ni,9)k
  end
  when m='353' then do; ch=word(f,2); a=words(g)
   if ch/='*' & (a>6 | translate(ch)=target) then call OUT hi||left(ch,15)yo||g
  end
  when m='313'|m='364' then b=f g
  when m='004'|m='318'|m='321'|m='365'|m='366'|m='406' then nop
  when m='001' then do; servername=s; b=subword(g,1,words(g)-1); end
  when m='252'|m='254' then b=f g
  otherwise select
   when g="" then b=f
   when f=""|f=s then b=g
   otherwise b=f":" g
  end
  if s/="" & s/=servername then b='('s')' b
  if numb then b='{'m'}' b
 end
 return translate(b,"@",msa)
 
VAR:
 parse arg x
 select
  when x=',' then return lastsender
  when x=':' then return lastjoin
  when x='A' then return away
  when x='C' then return target
  when x='H' then return m
  when x='I' then return invitation
  when x='K' then return cmdchar
  when x='N' then return ircnick
  when x='Q' then return query
  when x='S' then return servername
  when x='T' then do
   if query='' then return target
   else return query
  end
  when x='V' then return vers
  when x='Z' then return left(time(),5)
  when x='$' then return '$'
  otherwise return v.x
 end
 return '<error>'
 
SET:
 parse arg r
 if r='' then do i=1 to words(varnames)
  r=word(varnames,i); call S '$('r') is "'v.r'"'
 end
 else do
  parse var r a b
  if b='' then call S 'Variable' a 'has the value "'v.a'"'
  else do; v.a=b; if find(varnames,a)=0 then varnames=a varnames; end
 end
 return
 
EDIT:
 parse arg in
 if left(in,1)="!" then call EXECUTE substr(in,2)
 else if left(in,1)/=cmdchar then do
  if query/='' then call SEND 'PRIVMSG' query ':'in
  else if target/=0 then call SEND 'PRIVMSG' target ':'in
  else call S 'You should join a channel or query a user first'
 end
 else if left(in,2)=cmdchar' ' then call SEND 'PRIVMSG' target ':'substr(in,3)
 else call SHELL substr(in,2)
 return
 
SHELL:
 parse arg lin
 if abbrev('ALIAS', translate(word(lin,1)), 2) then do
  parse var lin . name lin
  if name='' then do i=1 to words(aliasnames)
   name=word(aliasnames,i); call S name': "'al.name'"'
  end
  else do
   upper name
   if lin='' then call S name': "'al.name'"'
   else do; al.name=lin
    if find(aliasnames,name)=0 then aliasnames=name aliasnames; end
  end
  return
 end
 do while lin^=''
  if left(lin,1)='*' then return
  parse var lin one '15'x lin
  par=; lc=; com='$'; al.com = one
  do while al.com^=''; a=al.com
   do while left(a,1)='%'
    parse var a '%'var a
    parse var par b par
    v.var=b
   end
   if par^='' then do; a=a par; par=''; end
   b=; do while a^=''
    parse var a k'$'y a
    if y='' then do; b=b||k; leave; end
    if left(y,1)='(' then do; parse var y 2 x')'y; a=y a; end
    else do; x=left(y,1); a=substr(y,2) a; end
    b=b||k||VAR(x)
   end
   parse var b com par '::' next
   upper com
   if next^='' then lin=next||'15'x||lin
   if find(lc, com)=0 then lc=com lc
   else do; call S 'Alias loop of "'com'" encountered'; return; end
  end
  call COMMAND com par
 end
 return
 
COMMAND:
 parse arg q r; out=; upper q
 select
  when abbrev('ABORT',q,2) then call BYE "your abort request"
  when abbrev('AWAY',q,2) then do; away=r; out="AWAY" r; end
  when abbrev('BYE',q,1)|abbrev('SIGNOFF',q,6)|abbrev('QUIT',q,3) then do
   call SEND('QUIT' r); call BYE; end
  when abbrev('CATALOG',q,2) then do; catmode=1; out='LIST' r; end
  when abbrev('CHANNEL',q,1) then do
   if r="" then do; call S "Talking to" target; return; end
   if target/="" & target/=0 then call SEND("PART" target);
   out="JOIN" r
  end
  when abbrev('CLEAR',q,2) then "VMFCLEAR"
  when abbrev('CMDCHARACTER',q,2) then cmdchar=left(r,1)
  when q='ECHO' then call OUT r
  when abbrev('EXECUTE',q,1) then call EXECUTE r
  when abbrev('EXPRESSION',q,4) then call SET word(r,1) EXPR(subword(r,2))
  when abbrev('FOLLOW',q,1) then out='JOIN' invitation
  when abbrev('HELP',q,1) then do
   address 'CMS' "HELP RXIRC"; say; end
  when q='IF' then do
   parse var r cond a r
   if translate(a)^='THEN' then call S "IF" cond": THEN is missing"
   else do
    rc = INTERP("if ("cond") then rc=0; else rc=1")
    if rc=0 then call COMMAND r
   end
  end
  when abbrev('INTERPRET',q,3) then call INTERP r
  when abbrev('INVITE',q,1) then do
   if words(r)=1 & target/=0 then out='INVITE' r target
   else out='INVITE' r
  end
  when abbrev('LASTLOG',q,2) then call LASTLOG r
  when abbrev('LOGGING',q,2) then call LOGGING r
  when abbrev('NICKNAME',q,1) then if r='' then out='WHOIS' ircnick
  else do; out='NICK' r; ircnick=r; capnick=translate(r); end
  when left(q,2)='PF' then 'CP SET' q r
  when abbrev('REPLY',q,1) then call QUERY lastsender
  when abbrev('SERVER',q,1) then call CONNECT r
  when q='SET' then call SET r
  when q='SKIP' & sourcing then if datatype(r,'w') then skiplines=r
  when abbrev('SOURCE',q,2) then call SOURCE r
  when abbrev('STATUS',q,1) then do; out='WHOIS' ircnick
   call OUT 'Target:' target'; Query:' query'; Invitation:' invitation'; Last sender:' lastsender'; Last joined:' lastjoin
  end
  when q='STOP' & sourcing then abortsource=1
  when abbrev('TALKTO',q,2) then do
   if r/="" then target=translate(word(r,1))
   call S 'Now talking to' target
  end
  when abbrev('TELL',q,2) then call TELL r
  when abbrev('TOGGLE',q,3) then call TOGGLE r
  when abbrev('VERSION',q,3) then do; out='VERSION' r
   if r='' then call S 'rxIRC' vers
  end
  when abbrev('VIEWLOG',q,2) & viewcmd/='' then do
   address 'CMS' viewcmd logfile; say; end
  when abbrev('XAMINE',q,1) then out='WHOIS' lastsender
  when abbrev('YELL',q,1) then call TELL word(r,1) '<'ircnick'>' subword(r,2)
  when q='CHOP' then out="MODE" target "+ooo" r
  when abbrev('DATE',q,1) then out="TIME" r
  when abbrev('DESCRIBE',q,2) then do; parse var r whom desc
   out='PRIVMSG' whom ':'msa'ACTION' desc||msa; end
  when abbrev('IGNORE',q,2) then call IGNORE r
  when q='K' then out="KICK" target r
  when abbrev('LOCALWHO',q,1)|q="LCL" then do
   who_empty=1; out="WHO *"right(domain,trunc(length(domain)/2)); end
  when q='M'|q='MSG'|abbrev('MESSAGE',q,3) then do
   parse var r ni r; out='PRIVMSG' ni ':'r; end
  when abbrev('QUERY',q,1) then call QUERY r
  when abbrev('REQUEST',q,3)|q='CTCP' then do
   parse var r ni rq .; upper rq
   if ni="" then ni=capnick
   if rq="" then rq="VERSION"
   out='PRIVMSG' ni ':'msa||rq||msa
  end
  when q='SAY' then out='PRIVMSG' target ':'r
  when q='SWHO' then out='NAMES'
  when q='T' then out='TOPIC' target ':'r
  when q='WHO' then do
   who_empty=1
   if r="" then out='WHO' target
   else out='WHO' r
  end
  when abbrev('TCPIPSTATUS',q,3) then do
   parse value SOCKET('SOCKETSETSTATUS') with rc . q etc
   call S 'Status' q '('rc');' etc'; Input buffer length is' length(buffer)
  end
  when abbrev('WHOIS',q,1) then if r="" then out='WHOIS' ircnick
  else out='WHOIS' r
  when abbrev('UMODE',q,1) then out='MODE' ircnick r
  when q='UNCHOP' then out="MODE" target "-ooo" r
  otherwise if ACTION(q r) then do
   call OUT '*' ircnick r
   if query="" then out='PRIVMSG' target ':'msa'ACTION' r||msa
   else out='PRIVMSG' query ':'msa'ACTION' r||msa
  end
  else do
   li=cmds; out=q r
   do while li/=''; parse var li el li
    if abbrev(el,q,1) then do; out=el r; leave; end
 end; end; end
 call SEND out
 out=; return
 
IGNORE:
 arg a
 do words(a)
  parse var a ig a
  z=find(ignore,ig); if z/=0 then
   ignore=strip(delword(ignore,z,1))
  else ignore=ig ignore
 end
 call OUT 'You are ignoring:' ignore
 if quiet then call S "And you don't send notices about it (quiet ignore)."
 return
 
QUERY:
 parse arg qq
 if query/='' then call S 'Terminating query with' query
 query=qq
 if qq/='' then call S 'Starting a query with' qq
 else call S 'Talking to' target
 return
 
LASTLOG:
 arg a
 if ^datatype(a,"W") | a<1 | a>80 then a=20
 else a=a-1
 'VMFCLEAR'; call S lo'Messages received last:'
 do i=curll-a to curll; if ll.i/='' then call OUT hi'|'yo||ll.i; end
 return
 
LOGGING:
 arg a
 if a='ON' & log=0 then do
  writelog "<--> IRC log started on" date() "at" time()
  say 'Logging started.'; log=1; end
 else if a='OFF' & log=1 then do
  writelog "<--> IRC log ended on" date() "at" time()
  say 'Logging ended.'; log=0; end
 else call S 'Logging is' onoff.log
 return
 
S:
 parse arg k
 say k
 if logevent/=0 then do
  curll=curll+1; ll.curll=x; logevent=0; k=curll-50; ll.k=; end
 if log then writelog k
 return
 
OUT:
 parse arg x
 if x="" then return
 if length(x) < 81 then q=0
 else do 1
  q=pos(word(x,2),x)-1; if q>30 | q<0 then q=3
  p=lastpos(" ",x,80)
  if p<30 then do; q=3; p=77; end
  call S left(x,p); x=substr(x,p+1)
  do while length(x)+q > 80
   p=lastpos(" ",x,80-q); if p<30 then do; q=3; p=77; end
   call S copies(" ",q)left(x,p); x=substr(x,p+1)
  end
 end
 call S copies(" ",q)x
 return
 
CONNECT:
 parse arg ircserver port .
 if ircserver="" then do
  call S "Tell me the internet address of an IRC server"
  return
 end
 if datatype(port)="NUM" then ircport = port
 if sock/='' then do; call SEND("QUIT"); call SHUT; "CP SLEEP 3 SEC"; end
 in.2=me x2c('4b404b') ':'ircname
 parse value SOCKET('SOCKET', 'AF_INET', 'SOCK_STREAM') with rc sock etc
 if rc/=0 then do; sock=; call BYE "socket error:" etc; end
 parse value SOCKET('SETSOCKOPT', sock,'SOL_SOCKET','SO_ASCII','ON') with rc . etc
 if rc/=0 then call BYE "SetSockOpt error:" etc
 call S "Connecting to" ircserver "on port" ircport"." etc
 parse value SOCKET('CONNECT', sock, 'AF_INET' ircport ircserver) with rc . etc
 if rc/=0 then call BYE "connect error:" etc
 parse value SOCKET('IOCTL', sock, 'FIONBIO', 1) with rc . etc
 if rc/=0 then call BYE "nonblocking I/O:" etc
 call SEND(x2c('D5C9C3D2') ircnick)
 call SEND(x2c('E4E2C5D9') in.2)
 call SOURCE "PROFILE", 1
 return
 
CTCP:
 parse arg fla bla
 if pos(msa,bla)=0 then return 1
 parse var bla . (msa) ctcp bla (msa) .
 select
  when ctcp="ACTION" then call OUT '*' s bla
  when ctcp="CLIENTINFO" then
    call MSAREPLY "CLIENTINFO ACTION CLIENTINFO FINGER TIME USERINFO VERSION"
  when ctcp="FINGER" then
    call MSAREPLY "FINGER" realname '('me'@'hostname'.'domain',',
      me'@'mynode') - Idle' trunc(time('E'),2) 'seconds'
  when ctcp="TIME" then call MSAREPLY "TIME" left(time(),5)
  when ctcp="USERINFO" then call MSAREPLY "USERINFO" userinfo
  when ctcp="VERSION" then
    call MSAREPLY "VERSION rxIRC" vers "VM/CMS",
      ":Survival package for VM-struck humans"
  otherwise if fla=1 then call MSAREPLY "ERRMSG Huh? Can't do" ctcp
 end
 return 0
 
MSAREPLY:
 parse arg lyrics
 call SEND("NOTICE" s ":"msa||lyrics||msa)
 return
 
SYNTAX:
 say errortext(rc)
 return
 
HALT:
 call BYE "halt request"
BYE:
 parse arg reason
 save_rc = rc
 if reason/="" then call S "Terminating because of" reason '('rc')'
 if log then do
  writelog "<--> IRC session ended on" date() "at" time()
  "FINIS * * *"
 end
 do i=1 to pf.0
  a=word(pf.i,2)
  if a='RETRIEVE' then iterate
  if a='UNDEFINED' then "CP SET" word(pf.i,1)
  else "CP SET" pf.i
 end
 i=1; parse var qt.i 'LINEND' a',' . 'CHARDEL' k',' .
 'CP TERM LINEND' a 'CHARDEL' k
 i=2; parse var qt.i 'LINESIZE' a',' .
 'CP TERM LINESIZE' a
 if sock/='' then do
  call SHUT
  parse value SOCKET('TERMINATE') with .
  "NUCXDROP RXSOCKET"
 end
 if have_rxwt then RESETVALUE('ALL')
 exit save_rc
 
ACTION:
 parse arg q r
 select
  when abbrev("APPLAUD",q,3) then a="applauds wholeheartedly"
  when q="BOW" then a="bows gracefully"
  when abbrev("COMFORT",q,3) then a="comforts you"
  when abbrev("CUDDLE",q,3) then a="cuddles you"
  when abbrev("DANCE",q,3) then a="dances a waltz with you"
  when abbrev("GIGGLE",q,3) then a="giggles inanely"
  when abbrev("GRIN",q,2) then a="grins"
  when q="HUG" then a="hugs you"
  when abbrev("LAUGH",q,2) then a="laughs wholeheartedly"
  when q="ME"|abbrev("EMOTE",q,1) then return 1
  when q="NOD" then a="nods solemnly"
  when abbrev("SHRUG",q,2) then a="shrugs"
  when abbrev("SIGH",q,2) then a="sighs deeply"
  when abbrev("SMILE",q,2) then a="smiles"
  when abbrev("THANK",q,2) then a="thanks you from the bottom of the heart"
  when abbrev("WAVE",q,2) then a="waves goodbye to you"
  when abbrev("WINK",q,2) then a="winks suggestively"
  when abbrev("YAWN",q,2) then a="yawns tiredly"
  otherwise return 0; end
 if r="" then r=a'.'
 else r=word(a,1) r'.'
 return 1
 
FINDM: procedure
 arg patlist, token
 do words(patlist)
  parse var patlist a patlist
  if MATCH(a,token) then return 1
 end
 return 0
 
MATCH: procedure
 arg pattern, token
 do i = 1 by 1 while i < length(pattern)
  ss = substr(pattern,i,2)
  select
   when ss = '**' then do
    pattern = delstr(pattern,i,1)
    i = i - 1
   end
   when ss = '*?' then pattern = overlay('?*',pattern,i,2)
   otherwise nop
  end
 end
 return MATCHINT(pattern,token)
 
MATCHINT: procedure
 arg pattern, token
 if pattern == token then return 1
 if pattern == '*' then return 1
 if verify(pattern,'*?','M') = 0 then return 0
 ptrp = 1
 ptrt = 1
 lenp = length(pattern)
 lent = length(token)
 do search = 1 by 1
  select
   when ptrp > lenp & ptrt > lent
   then return 1
   when ptrp > lenp then return 0
   when ptrt > lent then return 0
   otherwise nop
  end
  pchar = substr(pattern,ptrp,1)
  tchar = substr(token,ptrt,1)
  select
   when pchar = tchar | pchar = '?'
   then do
    ptrp = ptrp + 1
    ptrt = ptrt + 1
    iterate search
   end
   when pchar = '*' & ptrp = lenp
   then return 1
   when pchar = '*' then do
    ptrp = ptrp + 1
    pchar = substr(pattern,ptrp,1)
    do ptrt = ptrt to lent
     tchar = substr(token,ptrt,1)
     if pchar = tchar then do
      if ptrp = lenp & ptrt = lent
      then return 1
      if MATCHINT(substr(pattern,ptrp+1),substr(token,ptrt+1)) then return 1
     end
    end
    return 0
   end
   otherwise return 0
  end
 end
 call BYE 'a mistake'
 
SEND:
 parse arg qp
 if qp='' then return
 if left(qp, 9)='PRIVMSG +' then do
  parse var qp . '+'ni' :'tx
  call TELL ni tx
 end
 else do
  qp=translate(qp,beep||bold,beepch||boldch)
  parse value SOCKET('WRITE', sock, qp||cr||lf) with rc . etc
  if rc/=0 then call BYE "socket write error:" etc
 end
 return
 
SHUT:
 a=sock; sock=; servername=;
 parse value SOCKET('SHUTDOWN', a,'BOTH') with rc . etc
 if rc/=0 then call BYE "socket shut error:" etc
 parse value SOCKET('CLOSE', a) with rc . etc
 if rc/=0 then call BYE "socket close error:" etc
 return
 
NICE:
 parse arg a"@"bb; if bb="" then bb=mynode
 if nice.a.bb^='*' then do
  if nice.a.bb^='' then return nice.a.bb
  'NAMEF :userid' a ':node' bb ':nick (LIFO'
  if rc=0 then do;parse pull nice.a.bb .
   return nice.a.bb;end
  if bb=mynode then do; 'NAMEF :userid' a ':node :nick (LIFO'
   if rc=0 then do;parse pull nice.a.bb .
    pull ln .;if ln='' then return nice.a.bb;end
  end
  nice.a.bb='*';end
 if a='RSCS' then return bb
 return a
 
U@N:
 parse arg q p; if q='' then return 0 'missing args'
 upper q; parse var q q'@'r
 if r^='' then return q r p
 if word(p,1)='AT' then do
  parse var p . r p; upper r
  if r='' then return 0 'missing node'
  return q r p;end
 if u@n.q^='' then return u@n.q p
 'NAMEF :nick' q ':userid :node :via (LIFO'
 if rc=0 then do 1
  pull la; pull ln; pull li
  if li='' then leave
  parse value li ln mynode with a r .
  u@n.q=a r; if via.a.r='' then via.a.r=la
  return a r p
 end
 u@n.q = q mynode;return q mynode p
 
TELL:
 parse arg tea
 parse value U@N(tea) with xid xnod tea
 if xid=0 then do
  call OUT xnod tea
  return
 end
 err=; if translate(left(tea,4))='VIA ' then do
  parse var tea . via tea
  upper via
  if via='NONE' then via=;
  via.xid.xnod = via
 end
 else via=via.xid.xnod
 select
  when via='SMSG'|via='SEND' then do
   if xnod^=mynode then err='SEND & SMSG only local'
   else do
    if via='SMSG' then parse value diagrc(8,'SMSG' xid tea) with rc . err
    else do
     parse var tea cp? tea?
     if translate(cp?)='CP' then
       parse value diagrc(8,'SEND CP' xid translate(tea?)) with rc . err
     else parse value diagrc(8,'SEND' xid tea) with rc . err
  end; end; end
  when via=''|left(via,1)^="'" then do
   if via='RSCS' then do;viar=1;via='';end;else viar=0
   if via^='' then via='CMD' via
   if xid='RSCS'|(xid=rscs&xnod=mynode) then do
    if xnod=mynode&^viar then parse value diagrc(8,'SM' rscs tea) with rc . err
    else parse value diagrc(8,'SM' rscs via 'CMD' xnod tea) with rc . err
   end
   else do
    if xnod=mynode&^viar then parse value diagrc(8,'M' xid tea) with rc . err
    else parse value diagrc(8,'SM' rscs via 'MSG' xnod xid tea) with rc . err
   end
  end
  otherwise
  parse var via "'"via"'"
  if word(via,1)='CP' then do
   parse value diagrc(8,subword(via,2) tea) with rc . err
   if rc=1 then err=via "unknown."
  end
  else do
   if xnod=mynode|xnod='' then address cms via xid tea
   else address cms via NICE(xid'@'xnod) tea
   if rc>0 then err='Rc' rc 'from' via'.'
   if rc<0 then do;rc=24;err='Invalid VIA'; end
 end; end
 if err/='' then call OUT strip(translate(err,' ','15'x))
 return
 
SOURCE:
 arg a, b
 if a='' then do
  call S "You must specify a file to /source"
  return -1
 end
 a=a 'RXIRC *'
 "STATE" a
 if rc/=0 then do
  if b/=1 then call S 'Could not access' a
 end
 else do
  'MAKEBUF'; 'EXECIO * DISKR' a '(FIFO FINIS'; skiplines=0;
  do queued(); sourcing=1
   parse pull l; if abortsource then iterate
   if skiplines=0 then call SHELL strip(l)
   else skiplines=skiplines-1
  end
  abortsource=0; sourcing=0; 'DROPBUF'
 end
 return
 
TOGGLE:
 parse arg n o
 if ^datatype(n,'W')|n<1|n>24 then do
  call S 'Invalid PF key "'n'".'; return; end
 o = strip(o); sep = left(o,1)
 parse var o (sep) com (sep) o
 'CP SET PF'n 'IMM /TOGGLE' n sep||o||sep||com
 call SHELL strip(com)
 drop sep
 return
 
EXPR:
 procedure
 parse arg expr
 signal on SYNTAX
 INTERPRET("expr = ("expr")")
 signal off SYNTAX
 return expr
 
INTERP:
 procedure
 arg statement
 signal on SYNTAX; INTERPRET(statement); signal off SYNTAX
 return rc
 
EXECUTE:
 parse arg r
 if r='' then do
  say 'Suspending rxIRC; Enter "return" to return'
  r='SUBSET'
 end
 address 'CMS' r
 if rc=0 then say "rxIRC ready"
 else say "rxIRC ready("rc")"
 return