* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * * "If it's squinky, then you know it's BrilligWare!"            * *
      * *                                                               * *
      * * Source available at www.brilligware.com                       * *
      * * Brillig Enterprises (aka Chris Pando) (C)2008                 * *
      * *                                                               * *
      * * This work is licensed under a Creative Commons                * *
      * * Attribution-NonCommercial-ShareAlike License:                 * *
      * * http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode    * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * *                                                               * *
      * * *             Source Member Encryption v1.00                * * *
      * *                                                               * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      *  This program will encrypt a source file, utilizing CEERAND0 and  *
      *  %Xlate. The seed is a four byte binary field with a value        *
      *  between (inclusive) 0 (x'00000000') and 2 147 483 646            *
      *  (x'7FFFFFFE').                                                   *
      *                                                                   *
      *  This program is designed to run over source files with lengths   *
      *  between 13 and 240 (system limits).                              *
      *                                                                   *
      *  To run, override source file, and call. To encrypt, call with    *
      *  with a second paramter of 'E'; to decrypt, 'D'                   *
      *                                                                   *
      *  ovrdbf input src cp0105r                                         *
      *  call cp0105r (x'075BCD15' 'E')                                   *
      *  call cp0105r (x'075BCD15' 'D')                                   *
      *                                                                   *
      *  !DON'T FORGET YOUR SEED!                                         *
      *  Brillig Enterprises is not responsible for lost seeds/source.    *
      *  The NSA can probably recover this stuff, but I can't.            *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      *    PROGRAM REVISION LOG                                           *
      *    --------------------                                           *
      *                                                                   *
      *   Date       Nature of Revision                                   *
      *   ---------- --------------------------------------------------   *
      *   2008/05/28 Replace shuffle with Fisher-Yates algorithm          *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     h dftActGrp(*No) actGrp(*Caller) bndDir('QC2LE')
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... files ...                                                     *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     finput     uf   f  240        disk
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... procedure interfaces ...                                      *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *
      * ... entry interfaces ...
      *
     dcp0105r          pr
     d seed                          10u 0
     d function                       1a
     dcp0105r          pi
     d seed                          10u 0
     d function                       1a
      *
      * ... services (internal) ...
      *
     d xxcrypt         pr
      *
      * ... bindable procedures ...
      *
     d random          pr                  ExtProc('CEERAN0')
     d                               10u 0
     d                                8f
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... data structures ...                                           *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     d inputds         ds           240
     d  srcdta                      228
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... standalone variables ...                                      *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     d unshuffled      s             52    Inz('ABCDEFGHIJKLMNOPQRSTUVWXYZ+
     d                                          abcdefghijklmnopqrstuvwxyz')
     d shuffled        s                   Like(unshuffled)
     d                                     Inz('ABCDEFGHIJKLMNOPQRSTUVWXYZ+
     d                                          abcdefghijklmnopqrstuvwxyz')
     d from            s                   Like(unshuffled) Based(from@)
     d to              s                   Like(unshuffled) Based(to@)
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... Constants ...                                                 *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     d ENCRYPT         c                   'E'
     d DECRYPT         c                   'D'
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * *                                                               * *
      * * *                        Mainline                           * * *
      * *                                                               * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      /free
       *InLR = *On;
       Read input inputds;
       DoW (Not %Eof(input));

          xxcrypt();

          Update input inputds;
          Read input inputds;
       EndDo;
       Return;

       BegSr *InzSR;
          //
          // seed of 0 uses GMT; non-reproducible
          //
          If ( seed = 0 );
             seed = 1;
          EndIf;

          If ( function = Encrypt );
             from@ = %Addr(unshuffled);
             to@   = %Addr(shuffled);
          Else;
             to@   = %Addr(unshuffled);
             from@ = %Addr(shuffled);
          EndIf;
       EndSr;
      /end-free
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * *                                                               * *
      * * *                       Procedures                          * * *
      * *                                                               * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     p xxcrypt         b
     d                 pi

     d floater         s              8f
     d $I              s              5u 0
     d $J              s              5u 0
     d temp            s              1a
      /free

       // shuffle using Knuth variant of Fisher-Davis algorithm

       For $I = %Len(unshuffled) Downto 2;
          random(seed:floater);
          $J = floater * $I + 1;
          If ($I <> $J);
             temp                  = %Subst(shuffled:$I:1);
             %Subst(shuffled:$I:1) = %Subst(shuffled:$J:1);
             %Subst(shuffled:$J:1) = temp;
          EndIf;
       EndFor;

       // encrypt/decrypt using %Xlate

       srcdta = %Xlate( from : to : srcdta : 13 );

       Return;
      /end-free
     p xxcrypt         e