• Subject: Re: Exit Program for QIBM_QTG_DEVINIT
  • From: Scott Klement <klemscot@xxxxxxxxxxxx>
  • Date: Thu, 1 Mar 2001 17:26:09 -0600 (CST)


On Thu, 1 Mar 2001, Jnb ZI, Christophe Wenk wrote:
>
> I am looking for a CL or RPG Telnet Exit Program to give a TCP/IP
> Connection a device name such as TNxxxxxx. (xxxxxx) should be last two
> bytes of IP address. instead of the format QPADEV#####. Would
> appreciate any examples. 
> Thanks a lot Chris
> 

I actually just started writing one of these yesterday.   It appears to
work (although theres still some extra bells & whistles that I was 
going to add... and some better error reporting...)

I'll attach what I've got so far.  It works for me (at V4R5) maybe it'll
get you started...   (It's RPG IV, of course)


     D inet_ntoa       PR              *   ExtProc('inet_ntoa')
     D  ulong_addr                   10U 0 VALUE

     D Cmd             PR                  ExtPgm('QCMDEXC')
     D   Command                    200A   const
     D   Length                      15P 5 const

     D IsActiveDevice  PR             1N
     D   peObject                    10A   const

     D peUserDscInfo   S              1A
     D peDevDscInfo    S              1A
     D peCnnDscInfo    S              1A
     D peEnvOpt        S              1A
     D peEnvOptLen     S             10I 0
     D peAllowConn     S              1A
     D peAutoSignOn    S              1A

     D wkConnIP        S             16A

     D p_UserDscInfo   S               *   inz(*NULL)
     D dsUserDscInfo   DS                  based(p_UserDscInfo)
     D  dsUserLen                    10I 0
     D  dsUserProfile                10A
     D  dsUserCurLib                 10A
     D  dsUserProgram                10A
     D  dsUserMenu                   10A

     D p_DevDscInfo    S               *   inz(*NULL)
     D dsDevDscInfo    DS                  based(p_DevDscInfo)
     D  dsDevName                    10A
     D  dsDevFormat                   8A
     D  dsDevReserved                 2A
     D  dsDevAttrOff                 10I 0
     D  dsDevAttrLen                 10I 0

     D p_DDDI          S               *   inz(*NULL)
     D dsDDDI          DS                  based(p_DDDI)
     D  dsDDDIkbid                    3A
     D  dsDDDIreserv                  1A
     D  dsDDDIcodepg                 10I 0
     D  dsDDDIchrset                 10I 0

     D p_CnnDscInfo    S               *   inz(*NULL)
     D dsCnnDscInfo    DS                  based(p_CnnDscInfo)
     D  dsCnnLen                     10I 0
     D  dsCnnAddr                    20A
     D  dsCnnPWvalid                  1A
     D  dsCnnWStype                  12A

     D p_Addr          S               *
     D dsAddr          DS                  based(p_Addr)
     D  dsAddrLen                     3I 0
     D  dsAddrFamily                  3I 0
     D  dsAddrPort                    5U 0
     D  dsAddrIP                     10U 0

     c     *entry        plist
     c                   parm                    peUserDscInfo
     c                   parm                    peDevDscInfo
     c                   parm                    peCnnDscInfo
     c                   parm                    peEnvOpt
     c                   parm                    peEnvOptLen
     c                   parm                    peAllowConn
     c                   parm                    peAutoSignOn

     c                   eval      p_UserDscInfo = %addr(peUserDscInfo)
     c                   eval      p_DevDscInfo = %addr(peDevDscInfo)
     c                   eval      p_CnnDscInfo = %addr(peCnnDscInfo)

     C* TODO: Make this report the error properly.
     c                   if        dsCnnLen < 24
     c                   callp(E)  Cmd('SNDMSG MSG(''ISOTELIR4: Not enough'+
     c                             ' connection information!'')' +
     c                             ' TOUSR(KLEMSCOT)':200)
     c                   eval      *inlr = *on
     c                   return
     c                   endif

     c                   eval      p_DDDI = p_DevDscInfo + dsDevAttrOff
     c                   eval      p_Addr = %addr(dsCnnAddr)

     C* TODO: Make this report the error properly.
     c                   if        dsAddrLen < 8
     c                   callp(E)  Cmd('SNDMSG MSG(''Address is only ' +
     c                             %trim(%editc(dsAddrLen:'N')) +
     c                             ' bytes long!'') TOUSR(KLEMSCOT)':200)
     c                   eval      *inlr = *on
     c                   return
     c                   endif

     c                   eval      wkConnIP = %str(inet_ntoa(dsAddrIP))

     c*  When coming from IP 10.0.0.1, try to use device W3.
     C*    if thats not available, try W7, and then A5.
     c                   if        wkConnIP = '10.0.0.1'
     c                   eval      dsDevName = 'W3'
     c                   if        IsActiveDevice(dsDevName)
     c                   eval      dsDevName = 'W7'
     c                   if        IsActiveDevice(dsDevName)
     c                   eval      dsDevName = 'A5'
     c                   endif
     c                   endif
     c                   endif

     C** Assign a different device name (by IP) for each RF terminal
     c                   select
     c                   when      wkConnIP = '192.168.5.193'
     c                   eval      dsDevName = 'RF1'
     c                   when      wkConnIP = '192.168.5.194'
     c                   eval      dsDevName = 'RF2'
     c                   when      wkConnIP = '192.168.5.195'
     c                   eval      dsDevName = 'RF3'
     c                   when      wkConnIP = '192.168.5.196'
     c                   eval      dsDevName = 'RF4'
     c                   when      wkConnIP = '192.168.5.197'
     c                   eval      dsDevName = 'RF5'
     c                   when      wkConnIP = '192.168.5.198'
     c                   eval      dsDevName = 'RF6'
     c                   when      wkConnIP = '192.168.5.199'
     c                   eval      dsDevName = 'RF7'
     c                   when      wkConnIP = '192.168.5.200'
     c                   eval      dsDevName = 'RF8'
     c                   when      wkConnIP = '192.168.5.201'
     c                   eval      dsDevName = 'RF9'
     c                   when      wkConnIP = '192.168.5.202'
     c                   eval      dsDevName = 'RF10'
     c                   endsl

     C* this is a "safety net".  If our device name is
     C*  active, fall back to QPADEVxxxx
     c                   if        dsDevName <> *blanks
     c                   if        IsActiveDevice(dsDevName)
     c                   eval      dsDevName = *blanks
     c                   endif
     c                   endif

     c                   eval      *inlr = *on
     c                   return


     P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P*  Check to see if an active device exists with the
     P*    object name given...
     P*
     P*  TODO:  This procedure current reports "*OFF" (device not active)
     P*    whenever an error occurs.  It might be wise to report the errors
     P*    properly, somewhere...
     P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P IsActiveDevice  B
     D IsActiveDevice  PI             1N
     D   peObject                    10A   const

     D CrtUsrSpc       PR                  ExtPgm('QUSCRTUS')
     D   peUsrSpc                    20A   CONST
     D   peExtAtr                    10A   CONST
     D   peInitSiz                   10I 0 CONST
     D   peInitVal                    1A   CONST
     D   pePubAuth                   10A   CONST
     D   peText                      50A   CONST
     D   peReplace                   10A   CONST
     D   peErrors                   256A

     D RtvPtrUS        PR                  ExtPgm('QUSPTRUS')
     D   peUsrSpc                    20A   CONST
     D   pePointer                     *

     D dsEC            DS
     D  dsECBytesP             1      4I 0 INZ(256)
     D  dsECBytesA             5      8I 0 INZ(0)
     D  dsECMsgID              9     15
     D  dsECReserv            16     16
     D  dsECMsgDta            17    256

     D ListCfgDesc     PR                  ExtPgm('QDCLCFGD')
     D   QualUsrSpc                  20A   const
     D   Format                       8A   const
     D   CfgDescType                 10A   const
     D   ObjQualif                   40A   const
     D   StatQualif                  20A   const
     D   ErrorCode                  256A

     D p_UsrSpc        S               *
     D dsLH            DS                   BASED(p_UsrSpc)
     D*                                     Filler
     D   dsLHFill1                  103A
     D*                                     Status (I=Incomplete,C=Complete
     D*                                             F=Partially Complete)
     D   dsLHStatus                   1A
     D*                                     Filler
     D   dsLHFill2                   12A
     D*                                     Header Offset
     D   dsLHHdrOff                  10I 0
     D*                                     Header Size
     D   dsLHHdrSiz                  10I 0
     D*                                     List Offset
     D   dsLHLstOff                  10I 0
     D*                                     List Size
     D   dsLHLstSiz                  10I 0
     D*                                     Count of Entries in List
     D   dsLHEntCnt                  10I 0
     D*                                     Size of a single entry
     D   dsLHEntSiz                  10I 0

     D p_Cfg           S               *
     D dsCfg           DS                  based(p_Cfg)
     D   dsCfgStatus                 10I 0
     D   dsCfgName                   10A
     D   dsCfgCatg                   10A
     D   dsCfgHRStat                 20A
     D   dsCfgText                   50A
     D   dsCfgJob                    10A
     d   dsCfgUser                   10A
     d   dsCfgNbr                     6A
     D   dsCfgPasThr                 10A
     D   dsCfgAPIFmt                  8A
     D   dsCfgCmdSuf                  4A

     D wwEntry         S             10I 0

     C* create a user space & get a pointer to it
     c                   callp     CrtUsrSpc('ISOTELIR4 QTEMP':'USRSPC':
     c                              16*1024: x'00':'*ALL': *blanks:
     c                             '*YES': dsEC)
     c                   if        dsECBytesA > 0
     c                   return    *OFF
     c                   endif
     c                   callp     RtvPtrUS('ISOTELIR4 QTEMP': p_UsrSpc)

     C* dump config descriptions into this user space
     c                   callp     ListCfgDesc('ISOTELIR4 QTEMP':
     c                                   'CFGD0200': '*DEVD': peObject:
     c                                   '*GE       *VARYOFF': dsEC)
     c                   if        dsECBytesA > 0
     c                   return    *OFF
     c                   endif

     c                   if        dsLHEntCnt < 1
     c                   return    *OFF
     c                   endif

     C*  Find our description in the user space if
     C*    its in there...
     c                   do        dsLHEntCnt    wwEntry
     c                   eval      p_Cfg = p_UsrSpc + dsLHLstOff +
     c                                  ((wwEntry-1)*dsLHEntSiz)
     c                   if        dsCfgName = peObject
     c                   if        (dsCfgStatus<>20 and dsCfgStatus<>30)
     c                               or dsCfgJob <> *blanks
     c                   return    *ON
     c                   leave
     c                   else
     c                   return    *OFF
     c                   leave
     c                   endif
     c                   endif
     c                   enddo

     c                   return    *OFF
     P                 E

+---
| This is the Midrange System Mailing List!
| To submit a new message, send your mail to MIDRANGE-L@midrange.com.
| To subscribe to this list send email to MIDRANGE-L-SUB@midrange.com.
| To unsubscribe from this list send email to MIDRANGE-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---

As an Amazon Associate we earn from qualifying purchases.

This thread ...

Follow-Ups:
Replies:

Follow On AppleNews
Return to Archive home page | Return to MIDRANGE.COM home page

This mailing list archive is Copyright 1997-2021 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].

Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.