/* REXX: simple POP3 killer client, the top lines (incl. the full */ /* headers) of deleted mails are saved in an MBOX file. Only big */ /* messages (TOPB = 12000 bytes) are parsed by procedure ERASE. */ /* POPSTOP works with traditional POP-servers supporting commands */ /* LIST, TOP, DELE, QUIT, and login by either USER + PASS or APOP */ /* as in RfC 1939 (RfC 1734 AUTH and RfC 2595 STLS not supported) */ /* If anything doesn't work as expected POPSTOP won't send QUIT, */ /* and without final QUIT all prior DELE commands are ignored. */ /* Usage : POPSTOP userid:password@host (with authentication) */ /* or : POPSTOP :@host (skip authentication) */ /* Example: POPSTOP userid:password@pop3.server.example 2>&1 >log */ /* Example: PMREXX /Q POPSTOP userid:password@pop3.server.example */ /* Version 1.9 source */ /* Please configure procedure ERASE and the following variables, */ /* where MBOX is used to save up to TOPL lines of deleted mails: */ MBOX = 'd:\installed\netscape\mail\popstop' TOPB = 12000 /* accept all mails < TOPB bytes */ TOPL = 50 /* scanned body lines (POP3 TOP) */ VERB = 0 /* 0: less / 1: more VERBose log */ parse arg USER ':' PASS '@' HOST call TOPOP HOST, USER, PASS, MBOX, TOPB, TOPL, VERB exit 1 /* not reached, see TOPOP exits */ ERASE: procedure expose (EXPO) /* return 0 (ok.) or 1 (DELEted) */ arg SIZE /* used to detect mail bombs */ MAILBOMB = 2 * 1024 * 1024 /* e.g. 2 MB as MAILBOMB limit */ /* The following code is an example working for my "catch-all" */ /* subdomain: Parsed mails (more than TOPB bytes) to any bad */ /* address (e.g. a Message-ID) are always DELEted. Mails with */ /* more than 80,000 bytes to any address used in Usenet news */ /* are also DELEted (SWEN). MAILBOMBs are DELEted if they are */ /* not sent to an address for HUGE mails. */ /* With TFIND() it should be easy to find other headers, e.g. */ /* the number of recipients (To: + CC:) or the Content-Type:, */ /* but at the moment I only use X-Envelope-To: (non-standard). */ parse upper value TFIND( 'X-Envelope-To' ) with TOCC '@' . /* Normally header + TOPL lines of deleted mails are saved in */ /* file MBOX. For confirmed spam this is irrelevant, SpamCop */ /* probably knows it. I note X-Spam-Flag: YES (non-standard) */ /* in LINE.. (1: save truncated mail, 0: skip confirmed spam): */ LINE.. = ( 'YES' <> TFIND( 'X-Spam-Flag' )) if TOCC <> '' then do /* only for found X-Envelope-To: */ SWEN = 'NOBODY' /* SWEN sent to news address(es) */ HUGE = 'SECRET' /* address(es) for monster mails */ GOOD = 'POSTMASTER WEBMASTER ABUSE' SWEN HUGE if wordpos( TOCC, GOOD ) = 0 then return 1 if wordpos( TOCC, SWEN ) > 0 then do if SIZE > 80000 then return 1 end if wordpos( TOCC, HUGE ) = 0 then do N = MAGIC( 'TV UE JV' ) /* base64 MZ, PK, or %P attached */ if sign( N ) then do /* MAGIC found: note line number */ LINE.0 = N ; return 1 end end /* only HUGE gets MAGIC MAILBOMB */ else if SIZE > MAILBOMB then return 0 end return SIZE > MAILBOMB /* 1: DELEte it, 0: not DELEted */ /* ----- the rest should work without modifications ------------- */ /* 0.1: first public beta version */ /* 0.2: generate closing MIME multipart boundary (RfC 2045/2046) */ /* 0.3: SIZE argument added to ERASE for worm SWEN or mail bombs */ /* 0.4: APOP added by Frank Beythien, MD5 stuff simplified by me */ /* 0.5: X-Mozilla-Status: 0010 in MBOX for Netscape and Mozilla */ /* 0.6: added MAGIC( 'TV UE' ) to ERASE some base64 attachments */ /* 0.7: MAGIC bug fixed: folded MIME-header may start with TAB */ /* 0.8: new size limit 12000 = 1200 + 8100 * 4/3 base64 binary */ /* 0.9: new minimal SWEN size 80000 (was 100000) */ /* 1.0: simplified ERASE(), no more PURL version triggering SC */ /* 1.1: MAGIC() returns now 0 or the line number instead of 1 */ /* 1.2: modifications proposed by Frank Beythien: less VERBose */ /* output, configurable limits TOPB (bytes) & TOPL (lines). */ /* RXMSG() errors, TREAD() input, modified TOPEN() & TFAIL. */ /* 1.3: Bug fix: allow CR or LF in TREAD() input, not only CRLF. */ /* Added USER@HOST M mails (X bytes) - N DELEted (Y bytes). */ /* 1.4: PMREXX usage prepared in v1.3 now officially documented. */ /* 1.5: Accept quoted pair \\ and \" in MIME multipart boundary, */ /* and show number of truncated bytes in a text/plain part. */ /* Of course \, ", and others aren't allowed in a boundary. */ /* 1.6: Fix added MIME boundary to survive QP line continuation. */ /* 1.7: Added JV to MAGIC(), binary starts with %PDF or similar. */ /* 1.8: Optionally don't save truncated spam as seen in ERASE(). */ /* 1.9: Adopted boundary="" dead loop fix from popstop2.cmd 2.1. */ MAGIC: procedure expose (EXPO) /* guesswork for base64 magics */ STAT = 0 /* (with some obvious loopholes) */ B64S = 'abcdefghijklmnopqrstuvwxyz' B64S = translate( B64S ) || B64S || '0123456789+/' do N = 1 to LINE.0 select when STAT = 0 then do /* wait for end of header lines: */ if LINE.N == '' then STAT = 1 end when STAT = 1 then do /* wait for a possible boundary: */ if abbrev( LINE.N, '--' ) then STAT = 2 end when STAT = 2 then do /* wait for end of Content info: */ X = translate( translate( LINE.N,, d2c( 9 ))) if abbrev( X, 'CONTENT-' ) = 0 then if abbrev( X, ' ' ) = 0 then if abbrev( X, '--' ) = 0 then if X == '' then STAT = 3 else STAT = 1 end when STAT = 3 then do /* test specified base64 magics: */ X = wordpos( left( LINE.N, 2 ), arg( 1 )) if X > 0 & verify( LINE.N, B64S ) = 0 then return N if abbrev( LINE.N, '--' ) then STAT = 2 else STAT = 1 end end end return 0 TOPOP: procedure /* handle complete POP3 session */ parse arg HOST, USER, PASS, MBOX, TOPB, TOPL, VERB signal on novalue name TFAIL ; signal on syntax name TFAIL signal on failure name TFAIL ; signal on halt name TFAIL signal on notready name TFAIL CRLF = x2c( 0D0A ) ; EXPO = 'TSOCK CRLF LINE. VERB' PURL = 'purl.net/xyzzy/src/popstop.cmd v1.9' if HOST = '' then do parse source . . THIS N = '' subword( PURL, 2 ) N = 'or : PMREXX /Q' THIS 'login:sword@host' || CRLF || N N = 'usage:' THIS 'login:sword@host' || CRLF || N exit RXMSG( N ) /* pop.t-online.de uses RADIUS */ end /* pop.gmx.de uses APOP (MD5) */ if TOPEN( strip( HOST ), 110 ) then exit 1 if DOTOK( /* intro */ ) then exit EPOP3( 'init' ) parse var LINE.. '<' -0 N '>' /* RfC 1939: get APOP Message-ID */ if abbrev( N, '<' ) then do N = MD5( N || '>' || PASS ) if DOTOK( 'APOP' USER N ) then exit EPOP3( 'APOP' ) end else if USER <> '' | PASS <> '' then do if DOTOK( 'USER' USER ) then exit EPOP3( 'USER' ) if DOTOK( 'PASS' PASS ) then exit EPOP3( 'PASS' ) end /* USER without PASS or v.v. bad */ SUM. = 0 if DOTOK( 'LIST', . ) then do do N = 0 to LINE.0 /* RfC 1939: number size [info] */ parse var LINE.N LIST.N SIZE.N . end N do N = 1 to LIST.0 /* accept all mails < TOPB bytes */ SUM.1 = SUM.1 + 1 ; SUM.2 = SUM.2 + SIZE.N if SIZE.N < TOPB then iterate N if DOTOK( 'TOP' LIST.N TOPL, . ) = 0 then exit EPOP3( 'TOP' LIST.N ) if ERASE( SIZE.N ) = 0 then iterate N if LINE.. then call TMBOX MBOX, SIZE.N, PURL if VERB = 0 then do say "To:" TFIND( 'To' ) say "From:" TFIND( 'From' ) say "Subject:" TFIND( 'Subject' ) end /* else DOTOK shows full header */ if DOTOK( 'DELE' LIST.N ) then exit EPOP3( 'DELE' LIST.N ) SUM.3 = SUM.3 + 1 ; SUM.4 = SUM.4 + SIZE.N end N end if DOTOK( 'QUIT' ) then exit EPOP3( 'QUIT' ) call TSEND ; call SockClose TSOCK SUM.1 = SUM.1 'mails (' || SUM.2 'bytes)' SUM.3 = SUM.3 'DELEted (' || SUM.4 'bytes)' exit 1 - RXMSG( USER || '@' || HOST CRLF SUM.1 '-' SUM.3 ) TMBOX: procedure expose (EXPO) /* save TOP of DELEted in MBOX */ parse arg MBOX, SIZE, PURL X = date('w') date() time() ; parse var X WW DD MM YY X X = left( WW, 3 ) MM DD X YY ; Y = TFIND( 'Return-Path' ) if abbrev( Y, '<' ) then parse var Y '<' Y '>' if Y = '' then Y = '-' call lineout MBOX, 'From' Y X /* standard MBOX delimiter line */ X = translate( MBOX ) /* Netscape 3.x X-Mozilla-Status */ if sign( pos( 'NETSCAPE', X ) + pos( 'MOZILLA', X )) then do if TFIND( 'X-Mozilla-Status' ) == '' then call lineout MBOX, 'X-Mozilla-Status: 0010' end /* needed to mark as deleted (?) */ X = SIZE do N = 1 to LINE.0 /* protect "From " message line */ X = X - 2 - length( LINE.N ) if abbrev( LINE.N, 'From ' ) then call lineout MBOX, '>' || LINE.N else call lineout MBOX, LINE.N end N SIZE = ' --> [' || X 'of' SIZE 'bytes removed by' PURL || ']' X = TFIND( 'Content-Type' ) /* see MIME RfCs 2045 & 2046 for */ Y = translate( X ) /* stripping trailing blanks and */ N = abbrev( Y, 'MULTIPART/' ) /* removing "\" in quoted pairs */ if N = 1 then N = pos( 'BOUNDARY', Y ) call lineout MBOX, '' /* report truncation and version */ if N <> 0 then do /* preserve a multipart boundary */ parse var X =(N) '=' X ; X = strip( X ) if abbrev( X, '"' ) then do BOUNDARY = '' ; X = substr( X, 2 ) do until abbrev( X, '"' ) | X = '' parse var X N 2 X if N = '\' then parse var X N 2 X BOUNDARY = BOUNDARY || N end BOUNDARY = strip( BOUNDARY, 'T' ) end /* ";" after simple boundary ok. */ else parse value word( X, 1 ) with BOUNDARY ';' call lineout MBOX, '--' || BOUNDARY if abbrev( Y, 'MULTIPART/DIGEST' ) then call lineout MBOX, 'Content-Type: text/plain' call lineout MBOX, '' call lineout MBOX, SIZE call lineout MBOX, '--' || BOUNDARY || '--' end else call lineout MBOX, SIZE return lineout( MBOX, '' ) TFIND: procedure expose (EXPO) /* unfold + get specified header */ FWSP = right( d2c( 9 ), 2 ) /* RfC 2822: SP or TAB if folded */ HEAD = strip( translate( arg( 1 ))) if right( HEAD, 1 ) <> ':' then HEAD = HEAD || ':' do N = 1 to LINE.0 until abbrev( translate( LINE.N ), HEAD ) if LINE.N == '' then return '' end N /* return '' if HEADer not found */ HEAD = substr( LINE.N, 1 + length( HEAD )) do N = N + 1 to LINE.0 until X <= 1 X = verify( LINE.N, FWSP ) /* 1: next or 0: last header */ if X > 1 then HEAD = HEAD || ' ' || substr( LINE.N, X ) end N /* unfold FWS as SPace for REXX */ return substr( HEAD, max( 1, verify( HEAD, FWSP ))) DOTOK: procedure expose (EXPO) /* send stuff and get an answer, */ if arg( 1, 'e' ) then do /* 1st arg. omitted in 1st DOTOK */ if abbrev( arg( 1 ), 'PASS ' ) then say '>>> PASS' copies( '?', length( arg( 1 )) - 5 ) else say '>>>' arg( 1 ) if TSEND( arg( 1 ) || CRLF ) then exit EPOP3( 'send' ) end DATA = TREAD() ; if DATA == '' then exit EPOP3( 'no answer' ) parse var DATA LINE.. (CRLF) MORE say LINE.. /* LINE.. needed for APOP later */ if abbrev( LINE.., '+OK' ) = 0 then exit EPOP3( '+OK MIA' ) if arg( 2, 'e' ) then do /* 2nd arg. omitted: single line */ LINE.0 = 0 /* otherwise reset line counter */ do LOOP = 1 until DATA == '' do while sign( pos( CRLF, MORE )) parse var MORE DATA (CRLF) MORE if VERB then say DATA if DATA == '.' then if MORE == '' then return sign( LINE.0 ) else leave LOOP N = LINE.0 + 1 ; LINE.0 = N LINE.N = substr( DATA, 1 + abbrev( DATA, '.' )) end DATA = TREAD() ; MORE = MORE || DATA end LOOP /* adding new DATA to MORE stuff */ end /* return 0 if single +OK line */ else if MORE == '' then return 0 if MORE <> '' then say MORE /* display any unparsed rubbish */ exit EPOP3( 'unexpected' ) /* unexpected multi-line answer */ EPOP3: procedure expose (EXPO) /* close socket and show error */ call TSEND ; call SockClose TSOCK return RXMSG( 'POP3 error:' arg( 1 )) /* -------------------------------------------------------------- */ /* Credits: RSA Data Security, Inc. MD5 Message-Digest Algorithm, */ /* for an MD5 test suite see */ /* 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 ), '0123456789.' )) = 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( 'cannot GetHostByName' arg( 1 )) 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 call SockClose TSOCK /* SockClose() won't reset errno */ end return RXMSG( 'socket error' SockSock_Errno() value( 'errno' )) 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: say 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 = SockPSock_Errno( 'socket error' SockSock_Errno()) if symbol( 'TSOCK' ) = 'VAR' then TRAP = SockClose( TSOCK ) if condition() = '' then return arg( 1 ) /* drop into normal TRAP handler, 'sigl' + 'result' preserved: */ /* see , (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 0 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 1 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 */