home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 35 Internet / 35-Internet.zip / srev13g.zip / de_srea.cmd < prev    next >
OS/2 REXX Batch file  |  1999-04-23  |  18KB  |  598 lines
  1. /* 21 April 1999. Daniel Hellerstein (danielh@econ.ag.gov)
  2.  
  3.     de_sreA.CMD: The client-side component of the "SRE_A" 
  4.                  SRE-http encryption method
  5.  
  6. This os/2 rexx program will decrypt responses from SRE-http servers
  7. that have been encrypted using the "SRE_A" encryption method.
  8.  
  9. To use this program, you'll need to do the following (assuming
  10. you are running OS/2, and you have netspacape for OS/2):
  11.  
  12. a) Copy this file to an applications directory (it does NOT need
  13.    to be in your path). For example, C:\OS2\APPS
  14.  
  15. b) Tell Netscape to use this DE_SREA whenever it is recieves
  16.    a response from a server that has a mime type of
  17.    application/x-encrypt_SRE_A  
  18.   
  19.    To do this, you should set the following in NetScape:
  20.      1) Open NetScape "applications". 
  21.           for NS4.04 -- look in Edit-Preferences-Applications
  22.           for NS2.02 -- look in Options-General_Preferences-Applications
  23.  
  24.      2) Create a "new type" with:
  25.  
  26.          Mime Type: application/x-encrypt_SRE_A
  27.          Application to Use: cmd.exe /c "x:\dir\DoSREA.cmd PWD:sspwd"
  28.  
  29.            NOTE: the  double quote (") characters MUST be included in 
  30.                  this definition!
  31.  
  32.         where :
  33.  
  34.            sspwd   : is your "shared-secret password"
  35.                      If you do NOT specify the PWD:sspwd, then
  36.                      DE_SREA will ask you to provide a "shared-secret"
  37.                      password
  38.            x:\dir\ : is the path you copied this file to (for example,
  39.                      C:\OS2\APPS).
  40.  
  41. After completing steps a and b, you are ready to recieve encrypted
  42. files from an SRE-http web server. 
  43.  
  44. When you do recieve an "SRE_A encrypted" response from an SRE-http
  45. web server, NetScape should pop up a window that asks you to  
  46. "load" or"save" the file -- you should choose "load".  
  47. de_sreA.CMD will then be invoked.
  48.  
  49. After making sure you entered the correct password, de_sreA will
  50. decrypt the message, and will then ask you whether to display
  51. the message in a new NetScape window, or whether to save it to disk.
  52.  
  53. Although DE_SREA.CMD was developed under OS/2, it might work under
  54. different flavors of REXX -- we'll be checking on that.
  55.  
  56. */
  57.  
  58. /* ---------- Begin user changeable parameters --------- */
  59.  
  60. /* set this to be the  fully qualified default output directory */
  61. default_outdir=''
  62.  
  63.  
  64. /* ---------- END of user changeable parameters --------- */
  65.  
  66.  
  67. parse arg dafile 
  68.  
  69. hispwd=''
  70.  
  71. dafile=strip(dafile)
  72. if abbrev(translate(dafile),'PWD:')=1 then do
  73.    parse var dafile pwd dafile
  74.    parse var pwd . ':' hispwd
  75.    hispwd=strip(translate(hispwd))
  76. end /* do */
  77.  
  78.  
  79.  
  80. say "  <<<< The SRE-http decrypter (for the SRE_A encryption method) >>>>"
  81. say ' '
  82. if default_outdir='' then default_outdir=directory()
  83. outdir=strip(default_outdir,'t','\')||'\'
  84. crlf='0d0a'x
  85. daname='TEMP.OUT'
  86.  
  87. foo=rxfuncquery('sysloadfuncs') /* use rexxutil if it's available */
  88. if foo=1 then do
  89.   call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'
  90.   call SysLoadFuncs
  91. end
  92.  
  93. if dafile='' then do
  94.    call charout, "Enter name of application/x-encrypt_SRE_A file: "
  95.    pull dafile
  96. end 
  97.  
  98. dafile=strip(dafile)
  99.  
  100. /* 1) read the file */
  101. a=stream(dafile,'c','open read')
  102. if abbrev(translate(a),'READY')<>1 then do
  103.     say "Problem opening: "dafile '= 'a
  104.     call charout, ' (hit ENTER to continue)' ; pull foo
  105.     exit
  106. end /* do */
  107. ilen=stream(dafile,'c','query size')
  108. if ilen=0 | ilen='' then do
  109.     say "Problem querying: "dafile
  110.     call charout, ' (hit ENTER to continue)' ; pull foo
  111.     exit
  112. end /* do */
  113. stuff=charin(dafile,1,ilen)
  114. foo=stream(dafile,'c','close')
  115.  
  116. hash16='' ; ctype='' ; nonce='' ; seed='' ; epwd=''; clength=''
  117. server=''
  118. selector=''
  119.  
  120.  
  121. /* parse into head and body */
  122. abound=''
  123.  
  124. do forever
  125.    if stuff='' then do
  126.         say "Problem: no body for this file: " dafile
  127.         call charout, ' (hit ENTER to continue)';pull foo
  128.         exit
  129.    end /* do */
  130.    parse var stuff aline (crlf) stuff
  131.  
  132.    taline=strip(translate(aline))
  133.    if taline='' then leave      /* empty line signifies end of head */
  134.  
  135.    select
  136.      when abbrev(taline,'X-NONCE')=1  then do
  137.           parse var aline . ':' NONCE
  138.      end 
  139.  
  140.      when abbrev(taline,'X-HASH16')=1 then do
  141.         parse var aline . ':' hash16
  142.      end 
  143.  
  144.      when abbrev(taline,'CONTENT-TYPE')=1 then do
  145.           parse var aline . ':' ctype
  146.      end /* do */
  147.  
  148.      when abbrev(taline,'CONTENT-LENGTH')=1  then do
  149.           parse var aline . ':' clength
  150.         
  151.      end /* do */
  152.  
  153.      when abbrev(taline,'SERVER')=1     then do
  154.           parse var aline . ':' SERVER   
  155.      end /* do */
  156.     
  157.      when abbrev(taline,'X-SELECTOR')=1   then do
  158.           parse var aline . ':' SELECTOR   
  159.      end /* do */
  160.  
  161.      when abbrev(taline,'X-SEED')=1  then do   /* this should never be available */
  162.           parse var aline . ':' SEED    /* -- only used for debug runs */
  163.      end /* do */
  164.  
  165.      when abbrev(taline,'X-EPWD')=1  then do   /* this should never be available */
  166.           parse var aline . ':' EPWD    /* -- only used for debug runs */
  167.      end /* do */
  168.  
  169.      when abbrev(taline,'CONTENT-DISPOSITION')=1 then do      /* get "Filename" */
  170.           parse var taline . 'FILENAME' daname ';' .
  171.           daname=space(daname,0)
  172.           daname=strip(daname,,'=')
  173.           daname=strip(daname,,'"')
  174.      end /* do */
  175.  
  176.      otherwise nop
  177.    end  /* select */
  178. end /* do */
  179.  
  180. /* nonce and hash16 must be present */
  181. if nonce='' | hash16='' then do 
  182.     say ' Problem: nonce or hash16 is missing '
  183.     call charout, ' (hit ENTER to continue)' ; pull foo
  184.     exit
  185. end /* do */
  186.  
  187. say "De-encrypting: "||space(server'/'selector,0)
  188. ctype=strip(ctype); clength=strip(clength)
  189. say "    (mimetype= "ctype', length='clength 'bytes)'
  190. say
  191.  
  192. getspwd:
  193. if hispwd='' then do
  194.   call charout,' Please enter your "shared-secret" password: '
  195.   pull hispwd ; hispwd=space(hispwd,0)
  196. end
  197.  
  198. /* 1) combine nonce and hispwd */
  199. ss=strip(nonce)||hispwd
  200.  
  201. /* 2) compute md5 hash */
  202. md5=sref_md5x(ss)
  203.  
  204. /* 3) pull out first 16 characters */
  205. a16=translate(left(md5,16))
  206.  
  207. /* 4) compare to hash16 -- if wrong, ask for new password */
  208. if translate(a16)<>hash16 then do
  209.     say '  ! Incorrect "shared-secret" password. Please re-enter.'
  210.     say
  211.     hispwd=''
  212.     signal getspwd
  213. end
  214.  
  215. /* 5) extract last 3 seed numbers  */
  216. numeric digits 13
  217. ix=x2d(substr(md5,30,3))
  218. iy=x2d(substr(md5,27,3))
  219. iz=x2d(substr(md5,25,2))
  220.  
  221. /* 6) de-encrypt the file using a random number sequence */
  222. numeric digits 12
  223. mx32=4294967295
  224.  
  225. /* pack to multiple of 4 length */
  226. i4s=trunc(length(stuff)/4)
  227. i4sb=length(stuff)//4
  228. if i4sb>0 then do
  229.  i4s=i4s+1
  230.  stuff=stuff||copies(' ',i4sb)
  231. end
  232.  
  233. amask=''
  234. do mm=1 to length(stuff)/4
  235.   arand=random3(mx32)
  236.   darand=right(d2c(arand),4,0)
  237.   amask=amask||darand
  238.   if (mm//2500)=0 then say " @ "mm*4 
  239. end
  240.  
  241. aanew=bitxor(stuff,amask)
  242.  
  243. aanew=left(aanew,clength)  /* get rid of pad characters */
  244.  
  245. say
  246. call charout, "Display in a new NetScape window (Y/N)? "
  247. pull yn
  248. if yn='Y' then do
  249.     tmpfile=dafile
  250.     ijj=lastpos('.',dafile)
  251.     if ijj>0 then tmpfile=left(dafile,ijj-1)
  252.     do mm=1 to 99
  253.     t2=tmpfile||'.$'||mm
  254.        if stream(t2,'c','query exists')='' then leave
  255.     end /* do */
  256. /* write to t2 */
  257.     foo=stream(t2,'c','open write')
  258.     if abbrev(translate(foo),'READY')=0 then do
  259.         say "Problem: could not create temporary file: "t2
  260.         call charout, ' (hit ENTER to continue)' ; pull foo
  261.         exit
  262.     end /* do */
  263.     foo=charout(t2,aanew,1)
  264.     if foo<>0 then do
  265.         say "Problem: could not write temporary file: "t2
  266.         call charout, ' (hit ENTER to continue)' ; pull foo
  267.         exit
  268.     end /* do */
  269.     address cmd '@NETSCAPE  file:///'t2
  270.     foo=deleteme(t2)             /* cleanup */
  271. end /* do */
  272. else do
  273.    useout=getofile(outdir||daname)
  274.    if useout<>"" then do
  275.            foo=stream(useout,'c','open write')
  276.            foo=charout(useout,aanew,1)
  277.            if foo<>0 then do
  278.                 say "Problem writing "useout
  279.            end /* do */
  280.            else
  281.                 say "   .... "useout " written successfully "
  282.           foo=stream(useout,'c','close')
  283.            ill=lastpos('\',useout)
  284.            if ill>0 then  outdir=left(useout,ill)
  285.    end /* do */
  286. end /* do */
  287.  
  288. exit
  289.  
  290.  
  291. /****************************************************/
  292. /************** Ask for an output file *************/
  293. getofile:procedure
  294. parse arg defout
  295. do forever
  296.   aa="   Output to file (ENTER="defout"):"
  297.   if length(aa)>40 then do
  298.      say aa
  299.      call charout, "    ? "
  300.   end
  301.   else do
  302.     call charout,aa' ?'
  303.   end
  304.  
  305.   pull gfile2 ; gfile2=strip(gfile2)
  306.   if right(gfile2,1)='\' & defout<>'' then do
  307.      iu=lastpos('\',defout)
  308.      gfile2=gfile2||substr(defout,iu+1)
  309.   end
  310.   if gfile2='.'  then return ''
  311.   if gfile2="" then gfile2=defout
  312.   if gfile2="" then iterate
  313.   gfile0=stream(gfile2,'c','query exists')
  314.   if gfile0<>"" then do
  315.       call charout,'   'Gfile0 ' exists.  Overwrite (Y/N)'
  316.       pull anans
  317.       if abbrev(strip(anans),'Y')<>1 then iterate
  318.       foo=deleteme(gfile0)
  319.       if foo=1 then do
  320.          say "    Could not delete gfile0. Try a different file name"
  321.          iterate
  322.       end
  323.   end
  324.   return gfile2
  325. end /* do */
  326.  
  327.  
  328. deleteme:procedure
  329. parse arg afile
  330. if rxfuncquery('SYSFILEDELETE')=0 then foo=sysfiledelete(gfile0)
  331. if stream(gfile,'c','query exists')<>''then return 0
  332. return 1
  333.  
  334. /****************************************************/
  335. /****************************************************/
  336. /**************  Compute an MD5 hash *************/
  337. /* A fully rexx md5 digest computation procedure.
  338.   This is NOT FAST  --  for small strings it is
  339.   toleable (0.15 seconds on a p166 for 50 character strings),
  340.   but for larger strings (or files) it can take many seconds --
  341.   you should instead use a DLL product (such as MD5_OS2) */
  342.  
  343.  
  344. /*  ------------------------------ */
  345. sref_md5x:procedure
  346. parse arg stuff
  347.  
  348. numeric digits 11
  349. lenstuff=length(stuff)
  350.  
  351. c0=d2c(0)
  352. c1=d2c(128)
  353. c1a=d2c(255)
  354. c1111=c1a||c1a||c1a||c1a
  355. slen=length(stuff)*8
  356. slen512=slen//512
  357.  
  358. /* pad message to multiple of 512 bits.  Last 2 words are 64 bit # bits in message*/
  359. if slen512=448 then  addme=512
  360. if slen512<448 then addme=448-slen512
  361. if slen512>448 then addme=960-slen512
  362. addwords=addme/8
  363.  
  364. apad=c1||copies(c0,addwords-1)
  365.  
  366. xlen=reverse(right(d2c(lenstuff*8),4,c0))||c0||c0||c0||c0  /* 2**32 max bytes in message */
  367.  
  368. /* NEWSTUFF is the message to be md5'ed */
  369. newstuff=stuff||apad||xlen
  370.  
  371. /* starting values of registers */
  372.  a ='67452301'x;
  373.  b ='efcdab89'x;
  374.  c ='98badcfe'x;
  375.  d ='10325476'x;
  376.  
  377. lennews=length(newstuff)/4
  378.  
  379. /* loop through entire message */
  380. do i1 = 0 to ((lennews/16)-1)
  381.   i16=i1*64
  382.   do j=1 to 16
  383.      j4=((j-1)*4)+1
  384.      jj=i16+j4
  385.      m.j=reverse(substr(newstuff,jj,4))
  386.   end /* do */
  387.  
  388. /* transform this block of 16 chars to 4 values. Save prior values first */
  389.  aa=a;bb=b;cc=c;dd=d
  390.  
  391. /* do 4 rounds, 16 operations per round (rounds differ in bit'ing functions */
  392. S11=7
  393. S12=12
  394. S13=17
  395. S14=22
  396.   a=round1( a, b, c, d,   0 , S11, 3614090360); /* 1 */
  397.   d=round1( d, a, b, c,   1 , S12, 3905402710); /* 2 */
  398.   c=round1( c, d, a, b,   2 , S13,  606105819); /* 3 */
  399.   b=round1( b, c, d, a,   3 , S14, 3250441966); /* 4 */
  400.   a=round1( a, b, c, d,   4 , S11, 4118548399); /* 5 */
  401.   d=round1( d, a, b, c,   5 , S12, 1200080426); /* 6 */
  402.   c=round1( c, d, a, b,   6 , S13, 2821735955); /* 7 */
  403.   b=round1( b, c, d, a,   7 , S14, 4249261313); /* 8 */
  404.   a=round1( a, b, c, d,   8 , S11, 1770035416); /* 9 */
  405.   d=round1( d, a, b, c,   9 , S12, 2336552879); /* 10 */
  406.   c=round1( c, d, a, b,  10 , S13, 4294925233); /* 11 */
  407.   b=round1( b, c, d, a,  11 , S14, 2304563134); /* 12 */
  408.   a=round1( a, b, c, d,  12 , S11, 1804603682); /* 13 */
  409.   d=round1( d, a, b, c,  13 , S12, 4254626195); /* 14 */
  410.   c=round1( c, d, a, b,  14 , S13, 2792965006); /* 15 */
  411.   b=round1( b, c, d, a,  15 , S14, 1236535329); /* 16 */
  412.  
  413.   /* Round 2 */
  414. S21=5
  415. S22=9
  416. S23=14
  417. S24=20
  418. a= round2( a, b, c, d,   1 , S21, 4129170786); /* 17 */
  419. d= round2( d, a, b, c,   6 , S22, 3225465664); /* 18 */
  420. c=  round2( c, d, a, b,  11 , S23,  643717713); /* 19 */
  421. b=  round2( b, c, d, a,   0 , S24, 3921069994); /* 20 */
  422. a=  round2( a, b, c, d,   5 , S21, 3593408605); /* 21 */
  423. d=  round2( d, a, b, c,  10 , S22,   38016083); /* 22 */
  424. c=  round2( c, d, a, b,  15 , S23, 3634488961); /* 23 */
  425. b= round2( b, c, d, a,   4 , S24, 3889429448); /* 24 */
  426. a= round2( a, b, c, d,   9 , S21,  568446438); /* 25 */
  427. d= round2( d, a, b, c,  14 , S22, 3275163606); /* 26 */
  428. c=  round2( c, d, a, b,   3 , S23, 4107603335); /* 27 */
  429. b=  round2( b, c, d, a,   8 , S24, 1163531501); /* 28 */
  430. a=  round2( a, b, c, d,  13 , S21, 2850285829); /* 29 */
  431. d=  round2( d, a, b, c,   2 , S22, 4243563512); /* 30 */
  432. c=  round2( c, d, a, b,   7 , S23, 1735328473); /* 31 */
  433. b= round2( b, c, d, a,  12 , S24, 2368359562); /* 32 */
  434.  
  435.   /* Round 3 */
  436. S31= 4
  437. S32= 11
  438. S33= 16
  439. S34= 23
  440. a= round3( a, b, c, d,   5 , S31, 4294588738); /* 33 */
  441. d=  round3( d, a, b, c,   8 , S32, 2272392833); /* 34 */
  442. c=  round3( c, d, a, b,  11 , S33, 1839030562); /* 35 */
  443. b=  round3( b, c, d, a,  14 , S34, 4259657740); /* 36 */
  444. a=  round3( a, b, c, d,   1 , S31, 2763975236); /* 37 */
  445. d=  round3( d, a, b, c,   4 , S32, 1272893353); /* 38 */
  446. c=  round3( c, d, a, b,   7 , S33, 4139469664); /* 39 */
  447. b=  round3( b, c, d, a,  10 , S34, 3200236656); /* 40 */
  448. a=  round3( a, b, c, d,  13 , S31,  681279174); /* 41 */
  449. d=  round3( d, a, b, c,   0 , S32, 3936430074); /* 42 */
  450. c=  round3( c, d, a, b,   3 , S33, 3572445317); /* 43 */
  451. b=  round3( b, c, d, a,   6 , S34,   76029189); /* 44 */
  452. a=  round3( a, b, c, d,   9 , S31, 3654602809); /* 45 */
  453. d=  round3( d, a, b, c,  12 , S32, 3873151461); /* 46 */
  454. c=  round3( c, d, a, b,  15 , S33,  530742520); /* 47 */
  455. b=  round3( b, c, d, a,   2 , S34, 3299628645); /* 48 */
  456.  
  457.   /* Round 4 */
  458. S41=6
  459. S42=10
  460. S43=15
  461. s44=21
  462. a=round4( a, b, c, d,   0 , S41, 4096336452); /* 49 */
  463. d=round4( d, a, b, c,   7 , S42, 1126891415); /* 50 */
  464. c=round4( c, d, a, b,  14 , S43, 2878612391); /* 51 */
  465. b=round4( b, c, d, a,   5 , s44, 4237533241); /* 52 */
  466. a=round4( a, b, c, d,  12 , S41, 1700485571); /* 53 */
  467. d=round4( d, a, b, c,   3 , S42, 2399980690); /* 54 */
  468. c=round4( c, d, a, b,  10 , S43, 4293915773); /* 55 */
  469. b=round4( b, c, d, a,   1 , s44,  2240044497); /* 56 */
  470. a=round4( a, b, c, d,   8 , S41, 1873313359); /* 57 */
  471. d=round4( d, a, b, c,  15 , S42, 4264355552); /* 58 */
  472. c=round4( c, d, a, b,   6 , S43, 2734768916); /* 59 */
  473. b=round4( b, c, d, a,  13 , s44, 1309151649); /* 60 */
  474. a=round4( a, b, c, d,   4 , S41, 4149444226); /* 61 */
  475. d=round4( d, a, b, c,  11 , S42, 3174756917); /* 62 */
  476. c=round4( c, d, a, b,   2 , S43,  718787259); /* 63 */
  477. b=round4( b, c, d, a,   9 , s44, 3951481745); /* 64 */
  478.  
  479.  
  480. a=m32add(aa,a) ; b=m32add(bb,b) ; c=m32add(cc,c) ; d=m32add(dd,d)
  481.  
  482. end
  483.  
  484. aa=c2x(reverse(a))||c2x(reverse(b))||c2x(reverse(C))||c2x(reverse(D))
  485.  
  486. return lower(aa)
  487.  
  488.  
  489. /* round 1 to 4 functins */
  490.  
  491. round1:procedure expose m. c1111 c0 c1
  492. parse arg a1,b1,c1,d1,kth,shift,sini
  493. kth=kth+1
  494. t1=c2d(a1)+c2d(f(b1,c1,d1))+ c2d(m.kth) + sini
  495. t1a=right(d2c(t1),4,c0)
  496. t2=rotleft(t1a,shift)
  497. t3=m32add(t2,b1)
  498. return t3
  499.  
  500. round2:procedure expose m. c1111 c0 c1
  501. parse arg a1,b1,c1,d1,kth,shift,sini
  502. kth=kth+1
  503. t1=c2d(a1)+c2d(g(b1,c1,d1))+ c2d(m.kth) + sini
  504. t1a=right(d2c(t1),4,c0)
  505. t2=rotleft(t1a,shift)
  506. t3=m32add(t2,b1)
  507. return t3
  508.  
  509. round3:procedure expose m. c1111 c0 c1
  510. parse arg a1,b1,c1,d1,kth,shift,sini
  511. kth=kth+1
  512. t1=c2d(a1)+c2d(h(b1,c1,d1))+ c2d(m.kth) + sini
  513. t1a=right(d2c(t1),4,c0)
  514. t2=rotleft(t1a,shift)
  515. t3=m32add(t2,b1)
  516. return t3
  517.  
  518. round4:procedure expose m. c1111 c0 c1
  519. parse arg a1,b1,c1,d1,kth,shift,sini
  520. kth=kth+1
  521. t1=c2d(a1)+c2d(i(b1,c1,d1))+ c2d(m.kth) + sini
  522. t1a=right(d2c(t1),4,c0)
  523. t2=rotleft(t1a,shift)
  524. t3=m32add(t2,b1)
  525. return t3
  526.  
  527. /* add to "char" numbers, modulo 2**32, return as char */
  528. m32add:procedure expose c0 c1 c1111
  529. parse arg v1,v2
  530. t1=c2d(v1)+c2d(v2)
  531. t2=d2c(t1)
  532. t3=right(t2,4,c0)
  533. return t3
  534.  
  535. /*********** Basic functions */
  536. /* F(x, y, z) == (((x) & (y)) | ((~x) & (z))) */
  537. f:procedure expose c0 c1 c1111 
  538. parse arg x,y,z
  539. t1=bitand(x,y)
  540. notx=bitxor(x,c1111)
  541. t2=bitand(notx,z)
  542. return bitor(t1,t2)
  543.  
  544.  
  545. /* G(x, y, z) == (((x) & (z)) | ((y) & (~z)))*/
  546. g:procedure expose c0 c1 c1111
  547. parse arg x,y,z
  548. t1=bitand(x,z)
  549. notz=bitxor(z,c1111)
  550. t2=bitand(y,notz)
  551. return bitor(t1,t2)
  552.  
  553. /* H(x, y, z) == ((x) ^ (y) ^ (z)) */
  554. h:procedure expose c0 c1 c1111
  555. parse arg x,y,z
  556. t1=bitxor(x,y)
  557. return bitxor(t1,z)
  558.  
  559. /* I(x, y, z) == ((y) ^ ((x) | (~z))) */
  560. i:procedure expose c0 c1 c1111
  561. parse arg x,y,z
  562. notz=bitxor(z,c1111)
  563. t2=bitor(x,notz)
  564. return bitxor(y,t2)
  565.  
  566. /* bit rotate to the left by s positions */
  567. rotleft:procedure 
  568. parse arg achar,s
  569. if s=0 then return achar
  570.  
  571. bits=x2b(c2x(achar))
  572. lb=length(bits)
  573. t1=left(bits,s)
  574. t2=bits||t1
  575. yib=right(t2,lb)
  576. return x2c(b2x(yib))
  577.  
  578.  
  579.  
  580. /****************************************************/
  581. /****************************************************/
  582. /****************************************************/
  583. /* *********************** */
  584. /* UNIFORM DISTRIBUTION RANDOM # GENERATOR.  
  585.   FROM APPL STATIS 1982, VOL31 Pg183
  586.   Requires one to set ix iy and iz sees beforehand 
  587. */
  588. random3:procedure expose ix iy iz 
  589. parse arg mx32
  590. IX=(171*IX)//30269
  591. IY=(172*IY)//30307
  592. IZ=(170*IZ)//30323
  593. RANDOM=(IX/30269.) + (IY/30307.)  + (IZ/30323)
  594. random=trunc((random // 1.0)*mx32)
  595.  
  596. RETURN random
  597.  
  598.