* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * * "If it's squinky, then you know it's BrilligWare!"            * *
      * *                                                               * *
      * * Source available at http:www.brilligware.com                  * *
      * * Brillig Enterprises (aka Chris Pando) (C)2005                 * *
      * *                                                               * *
      * * This work is licensed under a Creative Commons                * *
      * * Attribution-NonCommercial-ShareAlike License:                 * *
      * * http://creativecommons.org/licenses/by-nc-sa/2.0/legalcode    * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * *                                                               * *
      * * *              Menu Documentation Tool                      * * *
      * *                                                               * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * CRTBNDRPG PGM(CPANDO/CP1220R) SRCFILE(CPANDO/SRC)                 *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     h dftActGrp(*No) actgrp(*new) bnddir('QC2LE')
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... files ...                                                     *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     fcp1220f   if   e           k disk
     fqsysprt   o    f  132        printer OflInd(*InOF)
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... procedure interfaces ...                                      *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     d cp1220r         pr
     d  initMenu                     10a
     d  prune                         1n
     d cp1220r         pi
     d  initMenu                     10a
     d  prune                         1n
      *
      * internal procedures
      *
     d clcAddress      pr              *
     d                               10i 0
     d compBSearch     pr            10i 0
     d                                 *   Value
     d                                 *   Value
     d compQSort       pr            10i 0
     d                                 *   Value
     d                                 *   Value
     d heapMe          pr
     d                                3a   Value
     d                               10a
     d init            pr
     d insert          pr
     d                               10a
     d load            pr
     d print           pr
     d pruneMnu        pr             1n
     d                               10a
     d prunePgm        pr             1n
     d                               10a
     d rtvObject       pr            10a
     d                               10i 0
     d sort            pr
      /EJECT
      *
      * external procedures (from the C run-time library)
      *
     d bsearch         pr              *   ExtProc('bsearch')
     d                                 *   Value
     d                                 *   Value
     d                               10i 0 Value
     d                               10i 0 Value
     d                                 *   Value ProcPtr
     d memcmp          pr            10i 0 ExtProc('memcmp')
     d                                 *   Value
     d                                 *   Value
     d                               10i 0 Value
     d memcpy          pr                  ExtProc('memcpy')
     d                                 *   Value
     d                                 *   Value
     d                               10i 0 Value
     d memmove         pr                  ExtProc('memmove')
     d                                 *   Value
     d                                 *   Value
     d                               10i 0 Value
     d qsort           pr                  ExtProc('qsort')
     d                                 *   Value
     d                               10i 0 Value
     d                               10i 0 Value
     d                                 *   Value ProcPtr
      *
      * external programs (from the Object APIs)
      *
     dcrtUsrSpc        pr                   ExtPgm('QUSCRTUS')
     d                               20a
     d                               10a
     d                                8b 0
     d                                1a
     d                               10a
     d                               50a
     d                               10a
     d                              256a
     drtvPtr           pr                   ExtPgm('QUSPTRUS')
     d                               20a
     d                                 *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... data structures ...                                           *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *
      * used for records in heap storage
      *
     d recordDS        ds                  Based(ds@)
     d  parent@                        *
     d  option                        3a
     d  object                       10a
     d  pathLen                      10i 0
     d  pathVar                       1a
      *
      * standard API error data structure
      *
     d errDS           DS
     d  errPrv                       10u 0          Inz(%Size(errDS))
     d  errAvl                       10u 0          Inz(0)
     d  errMSGID                      7a
     d                                1a            Inz(x'00')
     d  errDta                      240a
      /EJECT
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... standalone variables ...                                      *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     d USStart@        s               *
     d ds@             s               *   Based(ds@@)
     d @ptrs           s                   Like(objectPtr) Dim(32000)

     d stkPtrL         s             10i 0
     d stkPtrR         s             10i 0
     d pgmCount        s             10i 0 Inz(0)
     d objectPtr       s             10i 0
     d recordDSSize    s             10i 0 Inz(%Size(recordDS))
     d pointerSize     s             10i 0 Inz(%Size(ds@))
     d objectPtrSize   s             10i 0 Inz(%Size(objectPtr))

     d $I              s             10i 0
     d $J              s             10i 0
     d text            s            128a
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... constants ...                                                 *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     d MENU            C                   'M'
     d PROGRAM         C                   'P'
     d EDITWORD        C                   '  '
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * *                                                               * *
      * * *                        Mainline                           * * *
      * *                                                               * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      /free
       *InLR = *On;

       init();
       load();
       print();

       Return;
      /end-free
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                   *
      * ... "O" specs ...                                                 *
      *                                                                   *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     oqsysprt   e            detail      0  1
     o                       text               128
      /EJECT
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * *                                                               * *
      * * *                       Procedures                          * * *
      * *                                                               * *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * load arrays                                                       *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pload             b
     d                 pi
      /free
       DoU (stkPtrL > stkPtrR Or
            stkPtrR > 1000000 );
          If (%SubSt(option:1:1) = MENU);
             Chain object cp1220f;
             DoW (Not %Eof(cp1220f));
                Select;
                When (AAOBJECTYP = MENU);
                   If (Not pruneMnu(AAOBJECT));
                      stkPtrR = stkPtrR + 1;
                      heapMe( MENU + %EditW( AAOPTION : EDITWORD )
                            : AAOBJECT
                            );
                   EndIf;
                When (AAOBJECTYP = PROGRAM);
                   If (Not prune Or Not prunePgm(AAOBJECT));
                      stkPtrR = stkPtrR + 1;
                      heapMe( PROGRAM + %EditW( AAOPTION : EDITWORD )
                            : AAOBJECT
                            );
                   EndIf;
                Other;
                EndSL;
                ReadE object cp1220f;
             EndDo;
          EndIf;
          stkPtrL = stkPtrL + 1;
          ds@@    = clcAddress(stkPtrL);
       EndDo;

       Return;
      /end-free
     pload             e
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * print                                                             *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pprint            b
     d                 pi
      /free
       //
       // if pruning is on, then @ptrs is already loaded, otherwise,
       // compress and sort user space pointers before printing.
       //
       If (Not prune);
          sort();
          For $I = 1 to pgmCount;
             ds@@ = clcAddress($I);
             text = *Blanks;
             memcpy( %Addr(text)
                   : %Addr(pathVar)
                   : pathLen
                   );
             Except detail;
          EndFor;
       Else;
          For $I = 1 to pgmCount;
             text = *Blanks;
             ds@@ = clcAddress(@ptrs($I));
             memcpy( %Addr(text)
                   : %Addr(pathVar)
                   : pathLen
                   );
             Except detail;
          EndFor;
       EndIf;

       Return;
      /end-free
     pprint            e
      /EJECT
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * menus are not allowed to (transitively) refer to themselves       *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     ppruneMnu         b
     d                 pi             1n
     d testMenu                      10a
     d pmDS            ds                  LikeDS(recordDS) Based(pm@)
      /free
       pm@ = ds@;
       DoW (pmDS.parent@ <> *NULL And pmDS.object <> testMenu);
          pm@ = pmDS.parent@;
       EndDo;
       Return (pmDS.object = testMenu);
      /end-free
     ppruneMnu         e
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * Create a heap entry                                               *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pheapMe           b
     d                 pi
     d nuOption                            Like(Option) Value
     d nuObject                            Like(Object)

     d hmDS            ds                  LikeDS(recordDS) Based(hm@)

     d wrkVar          s             14a
     d wrkVarLen       s             10i 0
     d hm@             s               *   Based(hm@@)
      /free
       wrkVar    = %TrimR(nuObject) + '/' + %SubSt(nuOption:2:2);
       wrkVarLen = %Len(%TrimR(wrkVar));

       hm@@ = clcAddress(stkPtrR);
       hm@  = %Alloc(recordDSSize + pathLen + wrkVarLen);

       hmDS.parent@ = ds@;
       hmDS.option  = nuOption;
       hmDS.object  = nuObject;
       hmDS.pathLen = pathLen + wrkVarLen + 1;
       memcpy( %Addr(hmDS.pathVar)
             : %Addr(wrkVar)
             : wrkVarLen
             );
       memcpy( %Addr(hmDS.pathVar) + wrkVarLen + 1
             : %Addr(pathVar)
             : pathLen
             );
       Return;
      /end-free
     pheapMe           e
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * only want the first path to a program                             *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pprunePgm         b
     d                 pi             1n
     d testPgm                       10a
      /free
       If (*NULL = bsearch( %Addr(AAOBJECT)
                          : %Addr(@ptrs)
                          : pgmCount
                          : objectPtrSize
                          : %PAddr('COMPBSEARCH')
                          ) );
          Insert(AAOBJECT);
          Return *Off;
       Else;
          Return *On;
       EndIf;
      /end-free
     pprunePgm         e
      /EJECT
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * ... bsearch compare ...                                             *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pcompBSearch      b
     d                 pi            10i 0
     d a@                              *   Value
     d b@                              *   Value

     d cbsDS           ds                  LikeDS(recordDS) Based(cbs@)

     d compVal         s                   Based(a@) Like(AAOBJECT)
     d heapPtr         s                   Based(b@) Like(objectPtr)
     d cbs@            s               *   Based(cbs@@)
      /free
       cbs@@ = clcAddress(heapPtr);
       return memcmp( %Addr(compVal)
                    : %Addr(cbsDS.object)
                    : %Len(compVal)
                    );
      /end-free
     pcompBSearch      e
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * insert program into sorted array                                  *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pinsert           b
     d                 pi
     d pgmName                       10a
      /free

       $I = 1;
       DoW ( $I <= pgmCount And
             pgmName > rtvObject(@ptrs($I)) );
          $I = $I + 1;
       EndDo;
       If ($I > pgmCount);
          pgmCount = pgmCount + 1;
          @ptrs(pgmCount) = stkPtrR + 1;
       Else;
          memmove( %Addr(@ptrs($I)) + objectPtrSize
                 : %Addr(@ptrs($I))
                 : (pgmCount - $I + 1) * objectPtrSize
                 );
          @ptrs($I) = stkPtrR + 1;
          pgmCount = pgmCount + 1;
       EndIf;

       Return;
      /end-free
     pinsert           e
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * sort                                                              *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     psort             b
     d                 pi
     d rDS             ds                  LikeDS(recordDS) Based(r@)
     d r@              s               *   Based(r@@)
     d l@@             s               *
      /free
       //
       // ADDROUT sort - shift all program pointers to the left
       //                First pointer is always to root menu
       //
       pgmcount = 0;
       For $I = 2 to stkPtrR;
          r@@ = clcAddress($I);
          If ( PROGRAM = %SubSt(rDS.option:1:1) );
             pgmCount = pgmCount + 1;
             l@@ = clcAddress(pgmCount);
             memcpy( l@@
                   : r@@
                   : pointerSize
                   );
          EndIf;
       EndFor;
       qsort( USStart@
            : pgmCount
            : pointerSize
            : %PAddr('COMPQSORT')
            );
       Return;
      /end-free
     psort             e
      /EJECT
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * ... qsort compare ...                                               *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pcompQSort        b
     d                 pi            10i 0
     d ds1@@                           *   Value
     d ds2@@                           *   Value

     d ds1             ds                  LikeDS(recordDS) Based(ds1@)
     d ds2             ds                  LikeDS(recordDS) Based(ds2@)
     d ds1@            s               *   Based(ds1@@)
     d ds2@            s               *   Based(ds2@@)

     d compLen         s             10i 0
      /free
       If (ds1.pathLen < ds2.pathLen);
          compLen = ds1.pathLen;
       Else;
          compLen = ds2.pathLen;
       EndIf;
       Return memcmp( %Addr(ds1.pathVar)
                    : %Addr(ds2.pathVar)
                    : compLen
                    );
      /end-free
     pcompQSort        e
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * calculate address for user space from stack pointer               *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pclcAddress       b
     d                 pi              *
     d stkPtr                        10i 0
      /free
       Return (USStart@ + (stkPtr - 1)*pointerSize);
      /end-free
     pclcAddress       e
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * Retrieve an object name                                           *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     prtvObject        b
     d                 pi            10a
     d rp$I                          10i 0
     d rpDS            ds                  LikeDS(recordDS) Based(rp@)
     d rp@             s               *   Based(rp@@)
      /free
       rp@@ = clcAddress(rp$I);
       Return rpDS.object;
      /end-free
     prtvObject        e
      /EJECT
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      * Initialisation logic                                              *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     pinit             b
     d                 pi
     d usrSpc          s             20a   inz('CP1220    QTEMP')
     d size            s              8b 0 inz(16000000)
     d aut             s             10a   inz('*ALL')
     d delete          s             10a   inz('*YES')
     d blanks256       s            256a   Inz(*Blanks)
     d hex00           s              1a   Inz(x'00')
      /free
       crtusrspc( usrSpc
                : blanks256
                : size
                : hex00
                : aut
                : blanks256
                : delete
                : errDS
                );

       rtvPtr( usrSpc
             : USStart@
             );
       //
       // going to handload the root entry
       //
       stkPtrL   = 1;
       stkPtrR   = 1;
       ds@@      = USStart@;
       ds@       = %Alloc(recordDSSize + %Len(%TrimR(initMenu)) - 1);
       parent@   = *NULL;
       option    = MENU;
       object    = initMenu;
       pathLen   = %Len(%TrimR(initMenu));
       memcpy( %Addr(PathVar)
             : %Addr(initMenu)
             : pathLen
             );
       Return;
      /end-free
     pinit             e