Telnet Device Initialization Exit Program
For Telxon PTC-960SL terminals, here is a "telnet device initialization exit program" to assign names to the devices.
This is a program that runs on the AS/400 when the PTC connects, and assigns a device name, etc.
Here's a link to the relevant online
manual:
http://publib.boulder.ibm.com:80/cgi-bin/bookmgr/BOOKS/qb3anl03/E.5.1
Here's the program (written in RPG IV at V4R5) in case that's useful to you:
** Telnet Device Initialization Exit Program
**
** This prorgram is run by OS/400 as an "exit program". It
** is used to figure out which device names to assign to incoming
** TELNET clients. (People connecting via TCP/IP)
**
** To Compile:
** CRTBNDRPG ISOTELIR4 SRCFILE(LIBSOR/QRPGLESRC) DBGVIEW(*LIST)
**
** To Install:
** ** ONLY DO THIS IF ITS NOT ALREADY INSTALLED! **
** ** USE WRKREGINF TO FOR THIS EXITPNT TO SEE. **
** ADDEXITPGM EXITPNT(QIBM_QTG_DEVINIT) FORMAT(INIT0100)
** PGMNBR(*LOW) PGM(LIBRARY/ISOTELIR4)
**
H OPTION(*SRCSTMT) DFTACTGRP(*NO) ACTGRP(*NEW)
** This IBM-supplied proc converts an IP address to the
** "dotted octet" format (192.168.5.1 is dotted octet)
D inet_ntoa PR * ExtProc('inet_ntoa')
D ulong_addr 10U 0 VALUE
** This program executes a CL command
D Cmd PR ExtPgm('QCMDEXC')
D Command 200A const
D Length 15P 5 const
** Local sub-procedure to determine if a device is available
** for us to use. (i.e. Is the device already in use?)
D IsActiveDevice PR 1N
D peObject 10A const
** Parameters
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
** Local (module-level) variables
D wkConnIP S 16A
** User Description Info Structure
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
** Device Description Info Structure
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
** Display Device Description Information Structure
** (fields specific to displays as opposed to printers)
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
** Connection Description Info structure
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
** Internet Protocol (IP) address structure
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* If less than 24 bytes were passed, abort before we do any damage
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* Display Info & IP Addr structures depend upon info found in
C* the Device Desc and Conn Desc structures. Set them based
C* on the passed values.
c eval p_DDDI = p_DevDscInfo + dsDevAttrOff
c eval p_Addr = %addr(dsCnnAddr)
C* Abort program if IP address info is weird or not there.
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 if dsAddrFamily <> 2
c callp(E) Cmd('SNDMSG MSG(''Address is not ' +
c 'in IP v4 format!'') TOUSR(KLEMSCOT)':
c 200)
c eval *inlr = *on
c return
c endif
C* Get IP address in dotted-decimal format
c eval wkConnIP = %str(inet_ntoa(dsAddrIP))
C* This fancy code will assign the first session from Scott's PC
C* at home to 'W3', the 2nd to 'W7', the 3rd to 'A5' and the
C* remainder to QPADEVxxxx
C*
C* This is mainly here for example code. (manually forcing the
C* device name to be set is pointless w/RUMBA 2000, Linux tn5250,
C* newer versions of Client Access, etc)
c if wkConnIP = '192.168.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 device names for Misc IP addresses.
C* (Also see "Safety Net" below)
c select
C* MMM's PC
c when wkConnIP = '192.168.5.66'
c eval dsDevName = 'W6'
C* RF Terminals
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 (or unavailable) fall back to QPADEVxxxx by setting the
C* device name to *blanks
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 a device name is available for us to use.
P* Usually, if its unavailable its because the device is already
P* in use (thus the procedure name)
P*
P* Note that if an error occurs, we will return *OFF (device not
P* active). This will, essentially, cause the device to fall
P* back to a QPADEVxxxx device name, thanks to the "Safety Net"
P* coded above.
P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P IsActiveDevice B
D IsActiveDevice PI 1N
D peObject 10A const
** Create User Space API
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
** Retrieve Pointer to User Space API
D RtvPtrUS PR ExtPgm('QUSPTRUS')
D peUsrSpc 20A CONST
D pePointer *
** API Error Code Structure
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
** List Configuration Descriptions API
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
** (Generic) Structure for API List Headers
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
** List Entries for List Cfg Desc API
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
** Local (procedure-level) variables
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 and dsCfgStatus<>0)
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
Tips and Techniques accumulated by Thomas Bishop from various sources including, but not limited to, Midrange-L, RPG-L, Midrange Computing, and News/400.
Copyright © 2002 [Thomas Bishop]. All rights reserved. Revised: August 11, 2001.
|