Dynamical selected objects -- code

Dynamical selected objects -- code

Main program TFROBJC needs 2 parameters:
One is Source-Library
The other is Target-Library(Currently not used in the program), the target is for linking to FTP, SAVRSTOBJ used. You can modify the source to achieve your request.

The utility have following:
TFROBJC -- main program
TFROBJC1 -- create SAVOBJ command
TFROBJD -- object/member selection screen
TFROBJR -- object/member selection processing pgm

The utility will create a SAVF name same as source-library name stored in source library.

 Installation step:  
1.
mark TFROBJC last section following lines:
 /* SELECT OBJECT TO SAVED */
             CALL TFROBJR
 /* CONSTRUCT SAVRST COMMAND */
             RTVMBRD    FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
             IF (&CURRCD  > 0) +
                 CALL TFROBJC1 (&SRCLIB &TOLIB)

saved source and compiled it. 
Run TFROBJC to create QTEMP/SAVMBRLIST for TFROBJR compiled used. 

2. CRTDSPF TFROBJD

3. CRTBNDRPG TFROBJR

4. CRTCLPGM TFROBJC1

5. Unmarked TFROBJC lines marked at step 1. Recreate TFROBJC.

Utility usage:

CALL TFROBJC ('source-library' 'target-library')

 
or 

CALL TFROBJC ('QGPL' 'QGPL') 

   
File  : QCLSRC
Member: TFROBJC
Type  : CLP
Usage : CRTCLPGM TFROBJC  


             PGM  (&SRCLIB &TOLIB)

             DCL        VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
             DCL        VAR(&TOLIB)  TYPE(*CHAR) LEN(10)
             DCL        VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
             DCL        VAR(&CURRCD) TYPE(*DEC) LEN(10 0)

             DCLF       QAFDBASI
/* OUTPUT OBJ DESCRIPTION TO OUTFILE */
             DSPOBJD    OBJ(&SRCLIB/*ALL) OBJTYPE(*ALL) +
                          OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPOBJ)

/* OUTPUT FILE DESCRIPTION TO OUTFILE */
             DSPFD      FILE(&SRCLIB/*ALL) TYPE(*BASATR) +
                          OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFD)
             OVRDBF     FILE(QAFDBASI) TOFILE(QTEMP/DSPFD)

             DLTF       DSPMBRLIST
             MONMSG     CPF0000
 NEXT:
             RCVF
             MONMSG  CPF0864 EXEC(GOTO MBRLISTEND)
             IF    (&ATDTAT = 'S') +
             DSPFD      FILE(&ATLIB/&ATFILE) TYPE(*MBRLIST) +
                          OUTPUT(*OUTFILE) +
                          OUTFILE(QTEMP/DSPMBRLIST) OUTMBR(*FIRST *ADD)
             GOTO NEXT

 MBRLISTEND:
             DLTF QTEMP/SAVMBRLIST
             MONMSG CPF0000
             /* CREATE TEMP FILE TO SAVE SAVED MEMBER NAME AND OBJ */
             CRTDUPOBJ  OBJ(QAFDMBRL) FROMLIB(*LIBL) OBJTYPE(*FILE) +
                          TOLIB(QTEMP) NEWOBJ(SAVMBRLIST)
             ADDPFM     FILE(QTEMP/SAVMBRLIST) MBR(SAVMBRLIST)

 /* SELECT OBJECT TO SAVED */
             CALL TFROBJR
 /* CONSTRUCT SAVRST COMMAND */
             RTVMBRD    FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
             IF (&CURRCD  > 0) +
                 CALL TFROBJC1 (&SRCLIB &TOLIB)

             ENDPGM

 
File  : QCLSRC
Member: TFROBJC1
Type  : CLP
Usage : CRTCLPGM TFROBJC1


             PGM  (&SRCLIB &TOLIB)

             DCL        VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
             DCL        VAR(&TOLIB)  TYPE(*CHAR) LEN(10)
             DCL        VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
             DCL        VAR(&CMDSTR) TYPE(*CHAR) LEN(3000) +
                          VALUE('SAVOBJ OBJ(')
             DCL        VAR(&MLFILES) TYPE(*CHAR) LEN(10) +
                          VALUE('          ')
             DCL        VAR(&SAVFILE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&SAVOBJS) TYPE(*CHAR) LEN(7) +
                          VALUE('SAVOBJ ')
             DCL        VAR(&OBJS) TYPE(*CHAR) LEN(4) VALUE('OBJ(')
             DCL        VAR(&OBJSS) TYPE(*CHAR) LEN(150)
             DCL        VAR(&LIBS) TYPE(*CHAR) LEN(4) VALUE('LIB(')
             DCL        VAR(&DEVS) TYPE(*CHAR) LEN(11) +
                          VALUE('DEV(*SAVF) ')
             DCL        VAR(&OBJTYPS) TYPE(*CHAR) LEN(14) +
                          VALUE('OBJTYPE(*ALL) ')
             DCL        VAR(&SAVFS) TYPE(*CHAR) LEN(15) VALUE('SAVF(')
             DCL        VAR(&FILEMBRS) TYPE(*CHAR) LEN(15) +
                          VALUE('FILEMBR(')
             DCL        VAR(&LEFT) TYPE(*CHAR) LEN(1) VALUE('(')
             DCL        VAR(&RIGHT) TYPE(*CHAR) LEN(2) VALUE(') ')
             DCL        VAR(&SLASH) TYPE(*CHAR) LEN(1) VALUE('/')
             DCL        VAR(&MBRS) TYPE(*CHAR) LEN(300)
             DCL        VAR(&WITHMBRS) TYPE(*CHAR) LEN(1)

             DCLF       QAFDMBRL

             CHGVAR     &SAVFILE &SRCLIB
             DLTF       &SRCLIB/&SAVFILE
             MONMSG     CPF0000
             CRTSAVF    FILE(&SRCLIB/&SAVFILE)

             OVRDBF     FILE(QAFDMBRL) TOFILE(QTEMP/SAVMBRLIST)

 NEXT:
             RCVF
             MONMSG  CPF0864 EXEC(GOTO MBRLISTEND)
             IF         (&MLFILES *NE &MLFILE) DO
 /*                     SAVOBJ +
                          OBJ(FILE) LIB(SRCLIB) DEV(*SAVF) +
                          OBJTYPE(*FILE) SAVF(SRCLIB/SAVF) +
                          FILEMBR((FILE1 (MBR1 MBR2)) (FILE2 (MBR1 +
                          MBR2)))  */
             IF         (&MLFILES *NE '          '  *AND +
                         &MLNAME  *NE '          ') DO
             CHGVAR  &MBRS +
                       (&MBRS *TCAT &RIGHT *TCAT &RIGHT)
             ENDDO

             CHGVAR &MLFILES &MLFILE
             CHGVAR &OBJSS (&OBJSS *BCAT &MLFILE)

             IF (&MLNAME *NE '          ') DO
              CHGVAR  &MBRS +
                      (&MBRS *BCAT &LEFT *CAT &MLFILE *BCAT &LEFT)
              CHGVAR  &WITHMBRS '1'
             ENDDO

             ENDDO

             IF (&MLNAME *NE '          ') +
                CHGVAR  &MBRS +
                        (&MBRS *BCAT &MLNAME)

             GOTO NEXT
 MBRLISTEND:

             DLTOVR     FILE(*ALL)
             CHGVAR  &CMDSTR +
                    (&SAVOBJS *CAT +
                     &OBJS *TCAT &OBJSS *TCAT &RIGHT *CAT +
                     &LIBS *TCAT &MLLIB  *TCAT &RIGHT *CAT +
                     &DEVS *CAT +
                     &OBJTYPS *CAT +
                     &SAVFS *TCAT &SRCLIB *TCAT &SLASH *CAT +
                                 &SAVFILE *TCAT &RIGHT)

             CHGVAR  &MBRS +
                       (&MBRS *TCAT &RIGHT *TCAT &RIGHT *TCAT &RIGHT)
             IF (&WITHMBRS = '1') DO
             CHGVAR &CMDSTR +
                    (&CMDSTR *BCAT &FILEMBRS *CAT &MBRS)
             ENDDO

             CALL QCMDEXC (&CMDSTR 3000)
             SNDPGMMSG  MSG('SAVF' *BCAT &SAVFILE *BCAT 'created in' +
                          *BCAT &SRCLIB *TCAT '.') TOPGMQ(*PRV +
                          (TFROBJC))

             ENDPGM
 
File  : QDDSSRC
Member: TFROBJD
Type  : DSPF
Usage : CRTDSPF TFROBJD  
 

      *===============================================================
      *
      * To compile:
      *
      *      CRTDSPF  FILE(XXX/TFROBJD) SRCFILE(XXX/QDDSSRC)
      *
      *===============================================================
     A*
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A                                      PRINT
     A                                      ERRSFL
     A                                      CA03
     A                                      CA12
     A*
     A          R SFL1                      SFL
     A*
     A            SELECT         1   B  6  2
     A            MLFILE        10   O  6  4
     A            MLNAME        10   O  6 15
     A            MLCDAT         6   O  6 26
     A            MLCHGD         6   O  6 33
     A            ODOBNM        10   O  6 40
     A            ODOBTP         8   O  6 51
     A            ODOBOW        10   O  6 60
     A            ODLDAT         6   O  6 71
     A            ODCDAT         6   H
     A*
     A*
     A          R SF1CTL                    SFLCTL(SFL1)
     A                                      SFLSIZ(0017)
     A                                      SFLPAG(0016)
     A                                      OVERLAY
     A N32                                  SFLDSP
     A N31                                  SFLDSPCTL
     A  31                                  SFLCLR
     A  90                                  SFLEND(*MORE)
     A                                      SFLCSRRRN(&CSRRRN1)
     A            RRN1           4S 0H      SFLRCDNBR
     A            CSRRRN1        5S 0H
     A                                  1  2'TFROBJR '
     A                                  1 28'____________Your _Company name'
     A                                      COLOR(WHT)
     A                                  1 71DATE
     A                                      EDTCDE(Y)
     A                                  2 29'____________Select Object or SRC Member to save'
     A                                      COLOR(WHT)
     A                                  2 71TIME
     A                                  3  1'___X__'
     A                                  4  3'LIBRARY:'
     A            SAVLIB        10   O  4 12
     A                                  5  4'FILE'
     A                                      COLOR(WHT)
     A                                  5 15'MEMBER'
     A                                      COLOR(WHT)
     A                                  4 26'CRT'
     A                                      COLOR(WHT)
     A                                  5 26'DATE'
     A                                      COLOR(WHT)
     A                                  3 33'LAST'
     A                                      COLOR(WHT)
     A                                  4 33'CHANGE'
     A                                      COLOR(WHT)
     A                                  5 33'DATE'
     A                                      COLOR(WHT)
     A                                  5 40'OBJECT'
     A                                      COLOR(WHT)
     A                                  5 51'TYPE'
     A                                      COLOR(WHT)
     A                                  5 60'OWNER'
     A                                      COLOR(WHT)
     A                                  3 71'LAST'
     A                                      COLOR(WHT)
     A                                  4 71'CHANGED'
     A                                      COLOR(WHT)
     A                                  5 71'DATE'
     A                                      COLOR(WHT)
     A*
     A          R SFL2                      SFL
     A*
     A            SELECT         1   B  6  2
     A            ODLBNM        10   O  6  4
     A            ODOBNM        10   O  6 15
     A            ODOBTP         8   O  6 26
     A            ODOBAT        10   O  6 37
     A            ODCDAT         6   O  6 48
     A            ODLDAT         6   O  6 55
     A            ODOBOW        10   O  6 62
     A          R SF2CTL                    SFLCTL(SFL2)
     A                                      SFLSIZ(0017)
     A                                      SFLPAG(0016)
     A                                      OVERLAY
     A N32                                  SFLDSP
     A N31                                  SFLDSPCTL
     A  31                                  SFLCLR
     A  90                                  SFLEND(*MORE)
     A            RRN2           4S 0H
     A                                  1  2'TFROBJR '
     A                                  1 28'_Your Company name____________'
     A                                      COLOR(WHT)
     A                                  1 71DATE
     A                                      EDTCDE(Y)
     A                                  2 34''
     A                                      COLOR(WHT)
     A                                  2 71TIME
     A                                  3  1'___X__'
     A                                  5  4'LIBRARY'
     A                                      COLOR(WHT)
     A                                  5 15'OBJECT '
     A                                      COLOR(WHT)
     A                                  5 26'OBJTYPE'
     A                                      COLOR(WHT)
     A                                  5 37'ATTR'
     A                                      COLOR(WHT)
     A                                  4 48'CRT'
     A                                      COLOR(WHT)
     A                                  5 48'DATE'
     A                                      COLOR(WHT)
     A                                  4 48'CHG'
     A                                      COLOR(WHT)
     A                                  5 55'DATE'
     A                                      COLOR(WHT)
     A                                  5 62'OWNER'
     A                                      COLOR(WHT)
     A          R SFL3                      SFL
     A            SAVOBJ        10   O  6  4
     A            SAVMBR        10   O  6 15
     A            MLCDAT         6   O  6 27
     A            MLCHGD         6   O  6 34
     A            ODOBOW        10   O  6 41
      *
     A          R SF3CTL                    SFLCTL(SFL3)
     A                                      SFLSIZ(0017)
     A                                      SFLPAG(0016)
     A                                      OVERLAY
     A N32                                  SFLDSP
     A N31                                  SFLDSPCTL
     A  31                                  SFLCLR
     A  90                                  SFLEND(*MORE)
     A            RRN3           4S 0H
     A                                  1  2'TFROBJR '
     A                                  1 28'Your Company Name_____________'
     A                                      COLOR(WHT)
     A                                  1 71DATE
     A                                      EDTCDE(Y)
     A                                  2 34'_______Confirm Selection'
     A                                  2 71TIME
     A                                  3  1'_______Please press Enter to confirm'
     A                                  4  3'LIBRARY:'
     A            SAVLIB        10   O  4 12
     A                                  5  4'OBJECT     MEMBER'
     A                                      COLOR(WHT)
     A                                  4 27'CRT'
     A                                      COLOR(WHT)
     A                                  5 27'DATE'
     A                                      COLOR(WHT)
     A                                  3 34'LAST'
     A                                      COLOR(WHT)
     A                                  4 34'CHG'
     A                                      COLOR(WHT)
     A                                  5 34'DATE'
     A                                      COLOR(WHT)
     A                                  5 41'OWNER'
     A                                      COLOR(WHT)
     A          R FKEY1
     A*
     A                                 23  2'F3=Exit'
     A                                      COLOR(BLU)
     A                                 23 12'F12=Cancel'
     A                                      COLOR(BLU)


File  : QRPGLESRC
Member: TFROBJR
Type  : RPGLE
Usage : CRTBNDRPG TFROBJR


      *===============================================================
      *
      * To compile:
      *
      *      CRTBNDRPG  PGM(XXX/TFROBJR) SRCFILE(XXX/QRPGLESRC)
      *
      *===============================================================

     H DEBUG  OPTION(*SRCSTMT:*NODEBUGIO)
     H DftActGrp(*NO) ActGrp(*CALLER)

     FTFROBJD   cf   e             workstn
     F                                     sfile(sfl1:rrn1)
     F                                     sfile(sfl2:rrn2)
     F                                     sfile(sfl3:rrn3)
     F                                     infds(info)

     FDSPOBJ    if   e             disk
     FDSPMBRLISTif   e             disk
     FSAVMBRLISTO    e             disk    rename(QWHFDML : SAVMBRR)

      * Information data structure to hold attention indicator (AID) byte.
      * AID byte contains a code identifying the function
      * key used to return control to the program from the display file.
      * For more information see the DATA MANAGEMENT GUIDE.

     Dinfo             ds
     D cfkey                 369    369

      * Constants to compare to AID - F3, F12, F6, and ENTER keys.
      * Other values documented in DATA MANAGEMENT GUIDE.

     Dexit             C                   const(X'33')
     Dcancel           C                   const(X'3C')
     Dadd              C                   const(X'36')
     Denter            C                   const(X'F1')

      * Input parameter: Source Type or not

     D savrrn          S              5S 0
     D confirm         S              1

      * Clear the subfile, then call the recursive NextLevel procedure
     C                   ExSr      clrsfl
     C                   Exsr      loadsfl
     C                   Eval      *In90 = *on
     C                   If        rrn1 = 0
     C                   Eval      *in32 = *on
     C                   EndIf

     C*                  Eval      csrrrn1 = 1

      * Simply redisplay subfile until user hits Exit or Cancel

     C                   DoU       (cfkey = exit) or (cfkey = cancel)
     C                   Write     fkey1
     C                   ExFmt     sf1ctl
     C                   Exsr      prcsfl
     C                   If        confirm = '1'
     C                   leave
     C                   EndIf
     C                   EndDo

      * Close files and terminate.

     C                   Eval      *inlr = *on

      *********************************************************************
     C     ClrSfl        BegSr

      * Clear the subfile by activating SFLCLR and writing the subfile control
      * format.  Reset the subfile relative record number.

     C                   Eval      *in31 = *on
     C                   Eval      rrn1 = 0
     C                   Write     sf1ctl
     C                   Eval      *in31 = *off
      *
     C                   EndSr

      *********************************************************************
     C     Loadsfl       Begsr

      * Loop until EOF is encountered.
      * read DSPMBRLIST
     C                   Read      DSPMBRLIST
     C                   DoW       not %eof

     C                   Eval      select = ' '

      * Update the global RRN counter, and write the new subfile record.

     C                   Eval      rrn1 = rrn1 + 1
     C                   Write     sfl1
     C                   Read      DSPMBRLIST
     C                   EndDo
     C                   Eval      SAVLIB = MLLIB

      * read DSPOBJ
     C                   Reset                   SFL1
     C                   Read      DSPOBJ
     C                   DoW       not %eof

     C                   Eval      select = ' '

      * Update the global RRN counter, and write the new subfile record.

     C                   Eval      rrn1 = rrn1 + 1
     C                   Write     sfl1
     C                   Read      DSPOBJ
     C                   EndDo

     C                   Eval      savrrn = rrn1
     C                   Eval      rrn1 = 1

     C                   EndSr
      *********************************************************************
     C     PrcSfl        Begsr
      * clear sfl3
     C                   Eval      *in31 = *on
     C                   Eval      rrn3 = 0
     c                   Write     sf3ctl

     C                   Eval      *in31 = *off
     C                   z-add     1             idx               5 0
     C                   Eval      confirm = '0'
     C                   DoW       idx < savrrn

     C     idx           Chain     sfl1

     C                   If        select = 'X'

     C                   If        MLFILE <> *blanks
     C                   Eval      SavLIB  = SAVLIB
     C                   Eval      SavOBJ  = MLFILE
     C                   Eval      SavMBR  = MLNAME
     C                   Else
     C                   Eval      SavLIB  = SAVLIB
     C                   Eval      SavOBJ  = ODOBNM
     C                   Eval      SavMBR  = *BLANKS
     C                   Eval      MLCDAT  = ODCDAT
     C                   Eval      MLCHGD  = ODLDAT
     C                   EndIf

     C                   Z-add     idx           strrrn            4 0
     C                   Eval      rrn3 = rrn3 + 1
     C                   Write     sfl3
     C                   Eval      select = ' '
     C                   update    sfl1
     C                   EndIf

     C                   Eval      idx = idx + 1
     C                   EndDo
     C
     C                   If        rrn3 > 0
     C                   z-add     rrn3          savrrn3           4 0
     C                   Write     fkey1
     C                   ExFmt     sf3ctl
     C                   If        (cfkey <> exit) and (cfkey <> cancel)
     C                   Eval      confirm = '1'
     C                   Eval      idx = 1
     C                   Reset                   SAVMBRR
     C                   DoW       idx <= savrrn3
     C     idx           Chain     sfl3
     C                   Eval      MLLIB = SAVLIB
     C                   Eval      MLFILE= SAVOBJ
     C                   EVAL      MLNAME= SAVMBR
     C                   EVAL      MLSEU2= ODOBOW
     C                   Write     SAVMBRR
     C                   Eval      idx = idx + 1
     C                   EndDo
     C                   EndIf
     C                   EndIf
     C                   If        strrrn > 0
     C                   Z-add     strrrn        rrn1
     C                   Else
     C                   Z-add     csrrrn1       rrn1
     C                   EndIf
     C                   EndSr

0 comments

Oldest 

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

-ADS BY GOOGLE

SearchEnterpriseLinux

SearchDataCenter

Close