|
midrange.com
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 mailing list archive is Copyright 1997-2024 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.
