/* OS/2 REXX: 8bitMIME mail submission + CRAM-MD5 authentication  */

/* Usage: rxmailto <address> <password> <file> <subject>          */
/* ADDR <address>    one receiver for SMTP RCPT TO + header To:   */
/* PASS <password>   for preconfigured CRAM-MD5 SMTP AUTH server  */
/* BODY <file>       text mail body, ASCII or the local 8bit CODE */
/* SUBJ <subject>    mail subject, max. ASCII substring length 75 */

/* Configuration (edit the four corresponding variables below):   */
/* HELO        fully qualified domain name for SMTP EHLO and the  */
/*             Message-ID.  HELO should resolve to the actual IP. */
/* FROM        is the sender for SMTP MAIL FROM + header From:    */
/* SMTP        the mail submit agent (server) using port 587 for  */
/*             the specified FROM address.                        */
/* CODE        local charset used for 8bitMIME, e.g. windows-1252 */

/* Bugs and features:                                             */
/* - The input file with the body has to be a file, not a pipe.   */
/* - The script doesn't support spaces in ADDR, PASS, and FILE.   */
/* - The script tries to use 8bitMIME if needed, even if the PEER */
/*   doesn't support it.  Users are supposed to know their MSA.   */
/* - The script tries to use CRAM-MD5 authentication even if the  */
/*   MSA doesn't support it.  Again, users should know their MSA. */
/* - If the password is specified as dot the script switches to   */
/*   unauthenticated 'direct-to-MX' mode for tests with GETMX().  */
/* - If the 1st non-blank char. in the body is not '<' the mail   */
/*   is sent as text/plain, otherwise as text/html.  8bit char.s  */
/*   in the body trigger charset=windows-1252 (see variable CODE) */
/*   and body=8bitMIME, else the mail is sent as 7bit us-ascii.   */
/* - The SUB64() encoder can emit lines with more than 76 char.s, */
/*   not permitted by RfC 2047.  If you consider to fix this make */
/*   sure that it supports CODE='utf-8' without splitting UTF-8.  */

/* Procedures (for info):                                         */
/* INTRO       wrapper for initial TRANS(), shows server greeting */
/* AUTHX       wrapper for optional CRAM-MD5 challenge + response */
/* USAGE       usage message, if given show an erroneous argument */
/* INPUT       get mail body with dot-stuffing and CRLF lineends  */
/* B64.O       B64 encoding of Content-MD5 determined by INPUT()  */
/* SUB64       B64 encoding of non-ASCII subwords in SUBJ         */
/* GETMX       parse 'nslookup -q=mx' for direct-to-MX mail tests */
/* TRANS       send command to SMTP, expect reply code 2xy or 3x4 */
/* CRAM        CRAM-MD5   (RfC 2195) SASL-mechanism for SMTP AUTH */
/* HMAC        hashed MAC (RfC 2104) used by CRAM                 */
/* MD5         MD5 digest (RfC 1321) used by HMAC                 */
/* TOPEN       open TCP connection to server at given port        */
/* TREAD       read data from open socket                         */
/* TSEND       send data to open socket (or close sender side)    */
/* RXMSG       show an error message (message window or stderr)   */
/* TFAIL       show socket error RXMSG, close socket, catch trap  */
/* TRAP        process trap                                       */

/* Prerequisites:                         (Frank Ellermann, 2007) */
/* 1 - This source, see <http://purl.net/xyzzy/src/rxmailto.cmd>  */
/* 2 - OS/2 RxSock.dll available from IBM (REXX IPv4 sockets API) */
/* 3 - OS/2 nslookup.exe with a working DNS server configured in  */
/*     %ETC%\resolv2 - on my system the file D:\MPTN\ETC\RESOLV2, */
/*     for another tool modify procedure GETMX(), e.g. use "dig". */
/* 4 - Please modify HELO, FROM, SMTP, and CODE for your box:     */

   HELO = 'yourbox.example.org'  /* should be FQDN of sending box */
   FROM = 'sender@isp.example'   /* sender address used by script */
   SMTP = 'smtp.isp.example'     /* mail submit agent for sender  */
   CODE = 'windows-1252'         /* local 8bit charset for mails  */

   signal on novalue  name TRAP  ;  signal on syntax name TRAP
   signal on failure  name TRAP  ;  signal on halt   name TRAP
   CRLF = x2c( 0D0A )            ;  EXPO = 'TSOCK CRLF INFO'
   parse arg ADDR PASS BODY SUBJ ;  parse var ADDR . '@' PEER

   if PASS = ''   then  exit USAGE()
   if SUBJ = ''   then  exit USAGE( 'missing subject for mail' )
   if PEER = ''   then  exit USAGE( 'malformed address' ADDR )

   PURL = 'http://purl.net/xyzzy/src/rxmailto.cmd'
   PURL = 'rxmailto.cmd/0.1 (+' || PURL || ')'
   SUBJ = SUB64( SUBJ, CODE, length( 'subject:' ))
   BODY = INPUT( BODY )          /* sets also Content-MD5 in INFO */
   HEAD = 'Content-Transfer-Encoding:'

   if sign( verify( BODY, xrange( x2c( 0 ), x2c( 7F ))))
      then  parse value       CODE HEAD '8bit' with  TYPE HEAD
      else  parse value 'us-ascii' HEAD '7bit' with  TYPE HEAD
   if abbrev( strip( BODY, 'Leading' ), '<' )
      then  TEXT = 'text/html;'  'charset=' || TYPE
      else  TEXT = 'text/plain;' 'charset=' || TYPE
   if PASS <> '.'                /* if password is no dot use MSA */
      then  parse value          SMTP 587 with  PEER PORT
      else  parse value GETMX( PEER )  25 with  PEER PORT
   DATE = left( date( 'W' ), 3 ) || ',' date() time() '-0000'
   MESS = '<' || date( 'S' ) || time( 'S' ) || '@' || HELO || '>'
   HEAD = 'Content-Type:'  TEXT  || CRLF || HEAD
   HEAD = 'Content-MD5:'   INFO  || CRLF || HEAD
   HEAD = 'MIME-Version:'  1.0   || CRLF || HEAD
   HEAD = 'User-Agent:'    PURL  || CRLF || HEAD
   HEAD = 'Subject:'       SUBJ  || CRLF || HEAD
   HEAD = 'Message-ID:'    MESS  || CRLF || HEAD
   HEAD = 'Date:'          DATE  || CRLF || HEAD
   HEAD = 'To:'            ADDR  || CRLF || HEAD
   HEAD = 'From:'          FROM  || CRLF || HEAD
   if 0  then  do ;  say HEAD ;  exit 1   ;  end   /* if 1: debug */

   signal on novalue  name TFAIL ;  signal on syntax name TFAIL
   signal on failure  name TFAIL ;  signal on halt   name TFAIL
   TEXT = '<' || FROM || '>'     ;  ADDR = '<' || ADDR || '>'

   if TYPE <> 'us-ascii'   then  TEXT = TEXT 'body=8bitMIME'
   select                        /* normal SMTP terminated by NOP */
      when TOPEN( PEER, PORT           )  then  exit 1
      when INTRO( /* shows greeting */ )  then  nop
      when TRANS( 'ehlo' HELO          )  then  nop
      when AUTHX( 0  /* challenge   */ )  then  nop
      when AUTHX( 1  /* response    */ )  then  nop
      when TRANS( 'mail from:' || TEXT )  then  nop
      when TRANS( 'rcpt to:'   || ADDR )  then  nop
      when TRANS( 'data'               )  then  nop
      when TSEND( HEAD || CRLF         )  then  exit TFAIL()
      when TSEND( CRLF || BODY         )  then  exit TFAIL()
      when TRANS( '.'                  )  then  nop
      otherwise                  /* 0 after transmission success  */
         call TRANS 'quit'       ;  call SockClose TSOCK ;  exit 0
   end                           /* 1 after any transaction error */
   call TRANS 'quit'             ;  call SockClose TSOCK ;  exit 1

INTRO:                           /* reads variables PEER and PORT */
   say date( 'S' ) time() 'TCP connection with' PEER || ':' || PORT
   return TRANS()                /* show time() + server greeting */

AUTHX:                           /* write and read access on INFO */
   if PASS = '.'  then  return 0 /* handle CRAM-MD5 if PASS given */
   if arg( 1 )    then  return TRANS( CRAM( FROM, PASS, INFO ))
                  else  return TRANS( 'auth CRAM-MD5' )

USAGE:   procedure expose (EXPO) /* show usage or error message   */
   parse source . . THIS         /* (sorry, only SAY implemented) */
   TEXT = 'usage:'  THIS 'address password body-file subject'
   if arg( 1, 'e' ) then TEXT = 'error:' arg( 1 )  || CRLF || TEXT
   say TEXT ;  return 1

INPUT:   procedure expose (EXPO) /* read mail body in given file  */
   parse arg FILE                ;  signal on notready name TRAP
   BODY = ''                     ;  EOL  = x2c( 0A )
   INFO = MD5( /* init. */, '' ) /* init. context for Content-MD5 */
   TEXT = charin( FILE,, chars( FILE ))

   do while TEXT <> ''           /* dot-stuffing + CRLF lineends: */
      parse var TEXT HEAD (EOL) TEXT
      if abbrev( CRLF, right( HEAD, 1 ))  then  HEAD = HEAD || EOL
                                          else  HEAD = HEAD || CRLF
      INFO = MD5( HEAD, INFO )   /* update MD5 w/out dot stuffing */
      if abbrev( HEAD, '.' )              then  HEAD =  '.' || HEAD
      BODY = BODY || HEAD        /* input file locked until exit, */
   end                           /* intentionally not closed here */
   INFO = B64.O( x2c( MD5( /* final */, INFO )))
   return BODY

B64.O :  procedure               /* string to (unlimited) base64: */
   B64 = 'abcdefghijklmnopqrstuvwxyz'
   B64 = translate( B64 ) || B64 || '0123456789+/'

   SRC = x2b( c2x( arg( 1 ))) ;  DST = ''
   ADD = ( length( SRC ) / 4 ) // 3
   SRC = SRC || copies( '00', ADD )

   do while SRC <> ''
      parse var SRC N 7 SRC   ;  N = x2d( b2x( N ))
      DST = DST || substr( B64,  N + 1, 1 )
   end
   return DST || copies( '=', ADD )

SUB64:   procedure expose (EXPO) /* unstructured RFC 2047 encoder */
   parse arg SRC, CODE, OFS      ;  CODE = '=?' || CODE || '?B?'
   W = words( SRC )  ;  DST = '' ;  X = 0 ;  S = 1 ;  E = 0

   VCHAR = xrange( x2c( 21 ), x2c( 7E ))
   do N = 1 to W + 1
      V = sign( verify( word( SRC, N ), VCHAR ))

      if V = X & N <= W then  E = E + 1   ;  else  do
         SUB = subword( SRC, S, 1 + E - S )

         if X  then  do          /* B64 encode non-ASCII SUBwords */
            X = wordindex( '*' SRC, S + 1 ) - 2
            do while substr( SRC, X, 1 ) == ' '
               SUB = ' ' || SUB  ;  X = X - 1
            end                  /* include extra leading  spaces */
            X = wordindex( SRC '*', E + 1 ) - 2
            do while substr( SRC, X, 1 ) == ' '
               SUB = SUB || ' '  ;  X = X - 1
            end                  /* include extra trailing spaces */

            SUB = CODE || B64.O( SUB ) || '?='
         end

         X = 1 + length( SUB )   ;  OFS = X + OFS
         if OFS > 76 then  do    /* not strictly 2047 conforming: */
            DST = DST || CRLF    ;  OFS = X
         end                     /* chunks > 76 silently accepted */

         DST = DST SUB           ;  X = V
         S = N                   ;  E = N
      end
   end
   return substr( DST, 2 )

GETMX:   procedure expose (EXPO) /* parse `nslookup -q=mx` output */
   signal on error  name TRAP    ;  RXQ = rxqueue( 'GET' )
   arg NAME                      ;  PRI = copies( 9, digits())

   address CMD '@nslookup -q=mx' NAME '2>&1 | rxqueue' RXQ
   do while sign( queued())
      pull . ' = ' NEW ',' . ' = ' MX
      select
         when MX = '' | MX = '.'       then  nop
         when datatype( NEW, 'w' ) = 0 then  nop
         when NEW > PRI                then  nop
         otherwise   NAME = MX   ;  PRI = NEW
      end
   end
   return strip( NAME )

TRANS:   procedure expose (EXPO) /* send stuff and get an answer: */
   arg VERB .                 ;  MORE = ''
   if VERB <> ''  then  do
      if TSEND( arg( 1 ) || CRLF )  then  exit TFAIL()
      if VERB = 'QUIT'              then  call TSEND
      say substr( time( 'L' ), 4, 8 ) arg( 1 )
   end

   DATA = TREAD()
   do while DATA \== ''
      MORE = MORE || DATA
      do while sign( pos( CRLF, MORE ))
         parse var MORE DATA (CRLF) MORE
         say substr( time( 'L' ), 4, 8 ) DATA
      end
      if MORE == '' then do
         parse var DATA DATA INFO
         select
            when  length( DATA ) <> 3                 then nop
            when  sign( verify( DATA, '0123456789' )) then nop
            when  VERB = 'AUTH'  then  return ( DATA <> 334 )
            when  VERB = 'DATA'  then  return ( DATA <> 354 )
            otherwise   return 1 - abbrev( DATA, '2' )
         end                     /* 0: 2xx ok., 1: not 2xx is bad */
      end
      DATA = TREAD()
   end
   exit TFAIL()

/* -------------------------------------------------------------- */
/* To use CRAM-MD5 copy procedures CRAM, HMAC, and the MD5 stuff. */
/* CRAM( USER, PASS, CHALLENGE ) returns a base64 response for a  */
/* base64 challenge.  The challenge can have the form '+ base64'. */

CRAM  :  procedure               /* for CRAM details see RfC 2195 */
   B64 = 'abcdefghijklmnopqrstuvwxyz'
   B64 = translate( B64 ) || B64 || '0123456789+/'

   DST = '' ;  SRC = arg( 3 )    /* strip IMAP or POP3 AUTH '+ ': */
   if abbrev( SRC, '+ ' )  then  SRC = substr( SRC, 3 )
   do while abbrev( '==', SRC ) = 0
      parse var SRC ADD 2 SRC    /* if no B64 force REXX error 40 */
      ADD = d2x( pos( ADD, B64 ) - 1 )
      DST = DST || right( x2b( ADD ), 6, 0 )
   end
   SRC = x2c( b2x( left( DST, length( DST ) - 2 * length( SRC ))))
   SRC = x2b( c2x( arg( 1 ) HMAC( arg( 2 ), SRC )))
   DST = ''
   ADD = ( length( SRC ) / 4 ) // 3
   SRC = SRC || copies( '00', ADD )

   do while SRC <> ''
      parse var SRC N 7 SRC   ;  N = x2d( b2x( N ))
      DST = DST || substr( B64,  N + 1, 1 )
   end
   return DST || copies( '=', ADD )

/* -------------------------------------------------------------- */
/* To use HMAC-MD5 copy procedure HMAC and all MD5 procedures.    */
/* The typical key length is 16 bytes, e.g. x2c( MD5( secret )).  */
/* Use left( x2c( HMAC( key, msg )), 12 ) for the first 96 bits.  */

HMAC  :  procedure               /* for HMAC details see RfC 2104 */
   parse arg KEY, MSG            /* also known as KEYED-MD5       */

   if length( KEY ) > 64   then  KEY = x2c( MD5( KEY ))

   OPAD = bitxor( KEY, copies( '5C'x, 64 ), '00'x )
   IPAD = bitxor( KEY, copies( '36'x, 64 ), '00'x )
   return MD5( OPAD || x2c( MD5( IPAD || MSG )))

/* -------------------------------------------------------------- */
/* Credits: RSA Data Security, Inc. MD5 Message-Digest Algorithm, */
/* for an MD5 test suite see <http://purl.net/xyzzy/src/md5.cmd>  */
/* hash = MD5( bytes )                 => MD5 of an octet string  */
/* ctxt = MD5( bytes, '' )             => init.  new MD5 context  */
/* ctxt = MD5( bytes, ctxt )           => update old MD5 context  */
/* hash = MD5( /**/ , ctxt )           => finalize   MD5 context  */
/* hash = MD5( bytes, /**/, n )        => MD5 of n zero-fill bits */
/* ctxt = MD5( bytes, ''  , n )        => init.  MD5 bit context  */
/* ctxt = MD5( bytes, ctxt, n )        => update MD5 bit context  */

MD5   :  procedure               /* for MD5 details see RfC 1321  */
   if arg( 2 ) = ''  then  do    /* no or empty context => init.  */
      A = '67452301' ;  B = 'EFCDAB89' ;  LEN = 0
      C = '98BADCFE' ;  D = '10325476' ;  BIN = ''
   end
   else  parse value arg( 2 ) with  A B C D LEN BIN

   numeric digits 20             /* 20 digits for max. 2**64 bits */
   ADD = 8 * length( arg( 1 ))   /* use length ADD if no arg( 3 ) */
   NEW = length( BIN )           /* BIN = remaining bits, mod 512 */

   if arg( 3 ) = '' & NEW // 8 = 0  then  do
      MSG = x2c( b2x( BIN )) || arg( 1 )
      NEW = NEW + ADD         ;  ADD = NEW // 512
      NEW = NEW - ADD         ;  BIN = substr( MSG, NEW / 8 + 1 )
      LEN = LEN + NEW         ;  MSG = left( MSG, NEW / 8 )
      BIN = x2b( c2x( BIN ))     /* save up to 511 remaining bits */
   end                           /* code above is good for octets */
   else  do                      /* code below is for bit-strings */
      if arg( 3 ) <> '' then  ADD = arg( 3 )
      BIN = BIN || left( x2b( c2x( arg( 1 ))), ADD, 0 )
      NEW = NEW + ADD         ;  ADD = NEW // 512
      NEW = NEW - ADD         ;  MSG = left( BIN, NEW )
      LEN = LEN + NEW         ;  BIN = substr( BIN, NEW + 1 )
      MSG = x2c( b2x( MSG ))     /* caveat, for the 3rd argument  */
   end                           /*  you'll get what you paid for */

   if arg( 2, 'o' ) | ( arg( 1, 'o' ) & arg( 2 ) <> '' ) then  do
      LEN = LEN + ADD            /* compute total length in bits, */
      NEW = NEW + ADD            /* note NEW bits for final loop, */
      ADD = 448 - ADD            /* pad to length 448 modulo 512  */
      if ADD <= 0 then  ADD = ADD + 512
      BIN = b2x( BIN || left( 1, ADD, 0 ))
      MSG = MSG || x2c( BIN ) || reverse( x2c( d2x( LEN, 16 )))
      NEW = NEW + ADD + 64       /* reverse little endian length, */
      LEN = 'EOF'                /* using 16 * 4 = 512 - 448 bits */
   end
   call trace 'O' ;  trace 'N'   /* disable interactive MD5 trace */

   do N = 1 to NEW / 512         /* for MSG with N * 512 NEW bits */
      A = x2c( A )   ;  AA = A   ;  B = x2c( B )   ;  BB = B
      C = x2c( C )   ;  CC = C   ;  D = x2c( D )   ;  DD = D
      K = N * 64 - 63            /* fetch next 64 * 8 = 512 bits, */
      do J = 0 to 15             /* 512 = 16 * 32 bits to decimal */
         M.J = c2d( reverse( substr( MSG, K + J * 4, 4 )))
      end J

      A = MD5.1( A, B, C, D,  7, M.0  + 3614090360 )  /*  1 */
      D = MD5.1( D, A, B, C, 12, M.1  + 3905402710 )  /*  2 */
      C = MD5.1( C, D, A, B, 17, M.2  +  606105819 )  /*  3 */
      B = MD5.1( B, C, D, A, 22, M.3  + 3250441966 )  /*  4 */
      A = MD5.1( A, B, C, D,  7, M.4  + 4118548399 )  /*  5 */
      D = MD5.1( D, A, B, C, 12, M.5  + 1200080426 )  /*  6 */
      C = MD5.1( C, D, A, B, 17, M.6  + 2821735955 )  /*  7 */
      B = MD5.1( B, C, D, A, 22, M.7  + 4249261313 )  /*  8 */
      A = MD5.1( A, B, C, D,  7, M.8  + 1770035416 )  /*  9 */
      D = MD5.1( D, A, B, C, 12, M.9  + 2336552879 )  /* 10 */
      C = MD5.1( C, D, A, B, 17, M.10 + 4294925233 )  /* 11 */
      B = MD5.1( B, C, D, A, 22, M.11 + 2304563134 )  /* 12 */
      A = MD5.1( A, B, C, D,  7, M.12 + 1804603682 )  /* 13 */
      D = MD5.1( D, A, B, C, 12, M.13 + 4254626195 )  /* 14 */
      C = MD5.1( C, D, A, B, 17, M.14 + 2792965006 )  /* 15 */
      B = MD5.1( B, C, D, A, 22, M.15 + 1236535329 )  /* 16 */

      A = MD5.2( A, B, C, D,  5, M.1  + 4129170786 )  /* 17 */
      D = MD5.2( D, A, B, C,  9, M.6  + 3225465664 )  /* 18 */
      C = MD5.2( C, D, A, B, 14, M.11 +  643717713 )  /* 19 */
      B = MD5.2( B, C, D, A, 20, M.0  + 3921069994 )  /* 20 */
      A = MD5.2( A, B, C, D,  5, M.5  + 3593408605 )  /* 21 */
      D = MD5.2( D, A, B, C,  9, M.10 +   38016083 )  /* 22 */
      C = MD5.2( C, D, A, B, 14, M.15 + 3634488961 )  /* 23 */
      B = MD5.2( B, C, D, A, 20, M.4  + 3889429448 )  /* 24 */
      A = MD5.2( A, B, C, D,  5, M.9  +  568446438 )  /* 25 */
      D = MD5.2( D, A, B, C,  9, M.14 + 3275163606 )  /* 26 */
      C = MD5.2( C, D, A, B, 14, M.3  + 4107603335 )  /* 27 */
      B = MD5.2( B, C, D, A, 20, M.8  + 1163531501 )  /* 28 */
      A = MD5.2( A, B, C, D,  5, M.13 + 2850285829 )  /* 29 */
      D = MD5.2( D, A, B, C,  9, M.2  + 4243563512 )  /* 30 */
      C = MD5.2( C, D, A, B, 14, M.7  + 1735328473 )  /* 31 */
      B = MD5.2( B, C, D, A, 20, M.12 + 2368359562 )  /* 32 */

      A = MD5.3( A, B, C, D,  4, M.5  + 4294588738 )  /* 33 */
      D = MD5.3( D, A, B, C, 11, M.8  + 2272392833 )  /* 34 */
      C = MD5.3( C, D, A, B, 16, M.11 + 1839030562 )  /* 35 */
      B = MD5.3( B, C, D, A, 23, M.14 + 4259657740 )  /* 36 */
      A = MD5.3( A, B, C, D,  4, M.1  + 2763975236 )  /* 37 */
      D = MD5.3( D, A, B, C, 11, M.4  + 1272893353 )  /* 38 */
      C = MD5.3( C, D, A, B, 16, M.7  + 4139469664 )  /* 39 */
      B = MD5.3( B, C, D, A, 23, M.10 + 3200236656 )  /* 40 */
      A = MD5.3( A, B, C, D,  4, M.13 +  681279174 )  /* 41 */
      D = MD5.3( D, A, B, C, 11, M.0  + 3936430074 )  /* 42 */
      C = MD5.3( C, D, A, B, 16, M.3  + 3572445317 )  /* 43 */
      B = MD5.3( B, C, D, A, 23, M.6  +   76029189 )  /* 44 */
      A = MD5.3( A, B, C, D,  4, M.9  + 3654602809 )  /* 45 */
      D = MD5.3( D, A, B, C, 11, M.12 + 3873151461 )  /* 46 */
      C = MD5.3( C, D, A, B, 16, M.15 +  530742520 )  /* 47 */
      B = MD5.3( B, C, D, A, 23, M.2  + 3299628645 )  /* 48 */

      A = MD5.4( A, B, C, D,  6, M.0  + 4096336452 )  /* 49 */
      D = MD5.4( D, A, B, C, 10, M.7  + 1126891415 )  /* 50 */
      C = MD5.4( C, D, A, B, 15, M.14 + 2878612391 )  /* 51 */
      B = MD5.4( B, C, D, A, 21, M.5  + 4237533241 )  /* 52 */
      A = MD5.4( A, B, C, D,  6, M.12 + 1700485571 )  /* 53 */
      D = MD5.4( D, A, B, C, 10, M.3  + 2399980690 )  /* 54 */
      C = MD5.4( C, D, A, B, 15, M.10 + 4293915773 )  /* 55 */
      B = MD5.4( B, C, D, A, 21, M.1  + 2240044497 )  /* 56 */
      A = MD5.4( A, B, C, D,  6, M.8  + 1873313359 )  /* 57 */
      D = MD5.4( D, A, B, C, 10, M.15 + 4264355552 )  /* 58 */
      C = MD5.4( C, D, A, B, 15, M.6  + 2734768916 )  /* 59 */
      B = MD5.4( B, C, D, A, 21, M.13 + 1309151649 )  /* 60 */
      A = MD5.4( A, B, C, D,  6, M.4  + 4149444226 )  /* 61 */
      D = MD5.4( D, A, B, C, 10, M.11 + 3174756917 )  /* 62 */
      C = MD5.4( C, D, A, B, 15, M.2  +  718787259 )  /* 63 */
      B = MD5.4( B, C, D, A, 21, M.9  + 3951481745 )  /* 64 */

      A = d2x( c2d( AA ) + c2d( A ), 8 )
      B = d2x( c2d( BB ) + c2d( B ), 8 )
      C = d2x( c2d( CC ) + c2d( C ), 8 )
      D = d2x( c2d( DD ) + c2d( D ), 8 )
   end N

   if LEN = 'EOF' then  do       /* return lower case c2x( hash ) */
      MSG = reverse( x2c( D || C || B || A ))
      return translate( c2x( MSG ), 'abcdef', 'ABCDEF' )
   end                           /* caller uses x2c for real hash */
   else  return A B C D LEN BIN  /* return an updated MD5 context */

MD5.1 :  procedure               /* function used in MD5 round 1: */
   parse arg A, B, C, D, S, M
   C = bitor( bitand( B, C ), bitand( D, bitxor( B, 'FFFFFFFF'x )))
   signal MD5..                  /* = return MD5..(), common part */

MD5.2 :  procedure               /* function used in MD5 round 2: */
   parse arg A, B, C, D, S, M
   C = bitor( bitand( B, D ), bitand( C, bitxor( D, 'FFFFFFFF'x )))
   signal MD5..                  /* = return MD5..(), common part */

MD5.3 :  procedure               /* function used in MD5 round 3: */
   parse arg A, B, C, D, S, M
   C = bitxor( B, bitxor( C, D ))
   signal MD5..                  /* = return MD5..(), common part */

MD5.4 :  procedure               /* function used in MD5 round 4: */
   parse arg A, B, C, D, S, M
   C = bitxor( C, bitor( B, bitxor( D, 'FFFFFFFF'x )))
MD5.. :                          /* common part incl. S rotation: */
   C = x2b( d2x( c2d( A ) + c2d( C ) + M, 8 ))
   C = b2x( right( C || left( C, S ), 32 ))
   return x2c( d2x( x2d( C ) + c2d( B ), 8 ))

/* -------------------------------------------------------------- */
/* RXsock.dll interface (TOPEN, TREAD, TSEND, TFAIL) + gen. RXMSG */

TOPEN:   procedure expose (EXPO) /* TCP connect with HOST at PORT */
   if RxFuncQuery( 'SockLoadFuncs' ) then do
      call RxFuncAdd 'SockLoadFuncs', 'RXSOCK', 'SockLoadFuncs'
      call SockLoadFuncs 'N'     /* TRAP if RXSOCK.DLL not found  */
   end
   if datatype( value( 'TSOCK' ), 'w' )   then  call SockClose TSOCK

   if sign( verify( arg( 1 ), '0.123456789' )) = 0 then  do
      if SockGetHostByAddr( arg( 1 ), 'PEER.' ) = 0   then  do
         PEER.ADDR = arg( 1 ) ;  PEER.HOST = arg( 1 )
      end                        /* support IP without host name: */
   end                           /* SockConnect() handles bad IP  */
   else  if SockGetHostByName( arg( 1 ), 'PEER.' ) = 0
      then return RXMSG( 'unknown host' arg( 1 ) value( 'h_errno' ))

   PEER.PORT = arg( 2 )       ;  PEER.FAMILY = 'AF_INET'
   TSOCK = SockSocket( PEER.FAMILY, 'SOCK_STREAM', 'IPPROTO_TCP' )

   if 0 <= TSOCK then do
      if SockConnect( TSOCK, 'PEER.' ) = 0   then  return 0
   end                           /* 0: okay, connected with TSOCK */
   return TFAIL()                /* 1: error shown, socket closed */

TREAD:   procedure expose (EXPO) /* TCP read line (or data block) */
   READ = ''
   do until N < 2000 | sign( pos( x2c( 0A ), READ ))
      N = SockRecv( TSOCK, 'DATA', 2000 )
      if N > 0 then READ = READ || left( DATA, N )
   end
   return READ

TSEND:   procedure expose (EXPO) /* TCP send complete data block  */
   if arg( 1, 'e' )              /* 1: any error, 0: sent / close */
      then return length( arg( 1 )) <> SockSend( TSOCK, arg( 1 ))
      else return SockShutDown( TSOCK, 1 ) <> 0

RXMSG:   procedure expose (EXPO) /* show error message & return 1 */
   parse source . . THIS         ;  signal on syntax name RXMSG.TRAP
   call RxMessageBox arg( 1 ), THIS, /**/, 'HAND'  ;  return 1
RXMSG.TRAP:          call SockPSock_Errno arg( 1 ) ;  return 1

TFAIL:                           /* close sockets and handle TRAP */
   signal on novalue  name TRAP  ;  signal on syntax name TRAP
   signal on failure  name TRAP  ;  signal on halt   name TRAP
   TRAP = RXMSG( 'socket error' SockSock_Errno() value( 'errno' ))
   if symbol( 'TSOCK' ) = 'VAR' then TRAP = SockClose( TSOCK )
   if condition() = '' then return 1
   /* drop into normal TRAP handler, 'sigl' + 'result' preserved: */

/* see <URL:http://purl.net/xyzzy/rexxtrap.htm>, (c) F. Ellermann */

TRAP:                            /* select REXX exception handler */
   call trace 'O' ;  trace N           /* don't trace interactive */
   parse source TRAP                   /* source on separate line */
   TRAP = x2c( 0D ) || right( '+++', 10 ) TRAP || x2c( 0D0A )
   TRAP = TRAP || right( '+++', 10 )   /* = standard trace prefix */
   TRAP = TRAP strip( condition( 'c' ) 'trap:' condition( 'd' ))
   select
      when wordpos( condition( 'c' ), 'ERROR FAILURE' ) > 0 then do
         if condition( 'd' ) > ''      /* need an additional line */
            then TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
         TRAP = TRAP '(RC' rc || ')'   /* any system error codes  */
         if condition( 'c' ) = 'FAILURE' then rc = -3
      end
      when wordpos( condition( 'c' ), 'HALT SYNTAX'   ) > 0 then do
         if condition( 'c' ) = 'HALT' then rc = 4
         if condition( 'd' ) > '' & condition( 'd' ) <> rc then do
            if condition( 'd' ) <> errortext( rc ) then do
               TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
               TRAP = TRAP errortext( rc )
            end                        /* future condition( 'd' ) */
         end                           /* may use errortext( rc ) */
         else  TRAP = TRAP errortext( rc )
         rc = -rc                      /* rc < 0: REXX error code */
      end
      when condition( 'c' ) = 'NOVALUE'  then rc = -2 /* dubious  */
      when condition( 'c' ) = 'NOTREADY' then rc = -1 /* dubious  */
      otherwise                        /* force non-zero whole rc */
         if datatype( value( 'RC' ), 'W' ) = 0 then rc = 1
         if rc = 0                             then rc = 1
         if condition() = '' then TRAP = TRAP arg( 1 )
   end                                 /* direct: TRAP( message ) */

   TRAP = TRAP || x2c( 0D0A ) || format( sigl, 6 )
   signal on syntax name TRAP.SIGL     /* throw syntax error 3... */
   if 0 < sigl & sigl <= sourceline()  /* if no handle for source */
      then TRAP = TRAP '*-*' strip( sourceline( sigl ))
      else TRAP = TRAP '+++ (source line unavailable)'
TRAP.SIGL:                             /* ...catch syntax error 3 */
   if abbrev( right( TRAP, 2 + 6 ), x2c( 0D0A )) then do
      TRAP = TRAP '+++ (source line unreadable)'   ;  rc = -rc
   end
   select
      when 1 then do                   /* in pipes STDERR: output */
         parse version TRAP.REXX       /* REXX/Personal: \dev\con */
         if abbrev( TRAP.REXX, 'REXXSAA ' ) |                /**/ ,
            6 <= word( TRAP.REXX, 2 )  then  TRAP.REXX = 'STDERR'
                                       else  TRAP.REXX = '\dev\con'
         signal on syntax name TRAP.FAIL
         call lineout TRAP.REXX , TRAP /* fails if no more handle */
      end
      when 0 then do                   /* OS/2 PM or ooREXX on NT */
         signal on syntax name TRAP.FAIL
         call RxMessageBox translate( TRAP, ' ', x2c( 0D )), /**/ ,
            'Trap' time(),, 'ERROR'
      end
      otherwise   say TRAP ; trace ?L  /* interactive Label trace */
   end

   if condition() = 'SIGNAL' then signal TRAP.EXIT
TRAP.CALL:  return rc                  /* continue after CALL ON  */
TRAP.FAIL:  say TRAP ;  rc = 0 - rc    /* force TRAP error output */
TRAP.EXIT:  exit   rc                  /* exit for any SIGNAL ON  */