|
 |
|
API - QUSRMBRD
Posted By: Jamie Flanary Contact |
The QUSRMBRD (Retrieve Member Description) API returns descriptive
information about a member in a file.
D szMsgText S 255A
** Tells the APIs how long the buffers are that are being used.
D nBufLen S 10I 0
** The structure returned by the QusRMBRD API.
D szMbrd0100 DS INZ
D nBytesRtn 10I 0
D nBytesAval 10I 0
D szFileName 10A
D szLibName 10A
D szMbrName 10A
D szFileAttr 10A
D szSrcType 10A
D dtCrtDate 13A
D dtLstChg 13A
D szMbrText 50A
D bIsSource 1A
D RmtFile 1A
D LglPhyFile 1A
D ODPSharing 1A
D filler2 2A
D RecCount 10I 0
D DltRecCnt 10I 0
D DataSpaceSz 10I 0
D AccpthSz 10I 0
D NbrBasedOnMbr 10I 0
**----------------------------------------------------------------
** Input Parameters for the program.
**----------------------------------------------------------------
** Source file name
D szSrcFile S 10A
D szSrcLib S 10A
D szSrcMbr S 10A
**----------------------------------------------------------------
** Input Parameters to the QUSRMBRD API
**----------------------------------------------------------------
** Format to be returned
D szFmt S 8A Inz('MBRD0200')
** Qualified source file and library name
D szQualName S 20A
** Whether or not to ignore overrides (0=Ignore, 1 = Apply)
D bOvr S 1A Inz('0')
**----------------------------------------------------------------
** Call this program with 3 parameters:
** Parm(QRPGLESRC myLibr ORDENTRY)
** srcfile srclib srcmbr
**----------------------------------------------------------------
C *ENTRY PLIST
C Parm szSrcFile
C Parm szSrcLib
C Parm szSrcMbr
**----------------------------------------------------------------
** Call QusRMBRD to retrieve the specified source member's
**----------------------------------------------------------------
C Eval szQualName = szSrcFile + szSrcLib
C Eval nBufLen = %size(szMbrD0100)
**----------------------------------------------------------------
C Call(E) 'QUSRMBRD'
C Parm szMbrD0100
C Parm nBufLen
C Parm szFmt
C Parm szQualName
C Parm szSrcMbr
C Parm bOvr
**----------------------------------------------------------------
** If RTFMBRD failed, we tell the FTP client that it failed.
**----------------------------------------------------------------
C if %Error
C Eval szMsgText = 'RTVMBRD Failed'
C endif
C return
| |
API - QWCCVTDT
Posted By: Jamie Flanary Contact |
The AS/400 System API QWCCVTDT
is used to convert a date and time
value from one format to another format.
The API QWCCVTDT will show CPF1060, if CvtInputDate is defined as *YMD (another format is needed).
D CvtDate PR ExtPgm( 'QWCCVTDT' )
D CvtInputFmt 10
D CvtInputDate 17
D CvtOutputFmt 10
D CvtOutputDate 17
D CvtAPIError 272
D APIError DS
D BytesProvided 9B 0 Inz( 272 )
D BytesAvail 9B 0 Inz( 0 )
D MsgID 7 Inz( *Blanks )
D Reserved 1 Inz( *Blanks )
D MsgDta 256 Inz( *Blanks )
D Input S 17 Inz( '20031001123456123' )
D InputFmt S 10
D InputDate S 17
D OutputFmt S 10
D OutputDate S 17
C Eval InputFmt = '*YYMD'
C Eval InputDate = Input
C Eval OutputFmt = '*DTS'
C Clear OutputDate
C Reset APIError
C CallP CvtDate( InputFmt :
C InputDate :
C OutputFmt :
C OutputDate:
C APIError )
C Eval InputFmt = '*DTS'
C Eval InputDate = OutputDate
C Eval OutputFmt = '*YYMD'
C Clear OutputDate
C Reset APIError
C CallP CvtDate( InputFmt :
C InputDate :
C OutputFmt :
C OutputDate:
C APIError )
C Eval *InLR = *On
| |
API - QUSRJOBI
Posted By: Jamie Flanary Contact |
This API can be called to retrieve information about
a specific job. The Qualified Job Name (Job/User/Number)
can be passed to the API, or the job Internal Identifier
that can be retrieved via the QUSLJOB (List Job) API,
or "*" to retrieve the current job details.
Note: Ten Formats are available to retrieve
job information, These are:
JOBI0100 This format returns basic performance information about a job.
It is faster than the JOBI0150 format and the JOBI0200 format
(which also contain performance information). The reason that
this format is faster is that it does not touch as many
objects, causing less paging when retrieving information
about the job.
JOBI0150 This format returns additional performance information, and is
slower than the JOBI0100 format. It is similar to the JOBI0200
format, but is faster than that format because there is less
paging involved in retrieving the information.
JOBI0200 This format returns information equivalent to that found
on the Work with Active Jobs (WRKACTJOB) command.
JOBI0300 This format returns job queue and output queue information
for a job, as well as information about the submitter's job
if the job is a submitted batch job.
JOBI0400 This format primarily returns job attribute types of information,
but has other types of information as well.
JOBI0500 This format returns message logging information.
JOBI0600 This format returns information about active jobs only.
It is intended to supplement the JOBI0400 format.
It retrieves information from several additional objects
associated with the job, and therefore, it causes
additional paging.
JOBI0700 This format returns library list information
for an active job.
JOBI0800 This format returns signal information for an
active job.
JOBI0900 This format returns SQL open cursor information
for an active job.
D Inf_Len S 4B 0
* The following data structure is then returned to the
* calling program:
D Job_Inf DS 256
d JobName 9 18
d JobUser 19 28
d JobNumber 29 34
d InternalId 35 50
d Status 51 60
D JobType 61 61
D JobSubType 62 62
D Subsystem 63 72
D JobRunPty 73 76b 0
D SystemPool 77 80b 0
D ProcessUnit 81 84b 0
D AuxRequests 85 88b 0
D InteractTrans 89 92b 0
D TotRespTime 93 96b 0
d FunctionType 97 97
D FunctionName 98 107
D ActJobStatus 108 111
D Reserved 112 112
D DBLockWait 113 116b 0
D NDBLockWait 117 120b 0
D MchLockWait 121 124b 0
D TimeDBLckW 125 127
D TimeNDBLckW 128 130
D TimeMchLckW 131 133
* For this program, an the parms are used:
c *entry plist
c parm CTJob 10
c parm CTUser 10
c parm CTJobN 6
c parm Job_Inf 256
* or you could use the Internal Job ID (*char 16) which
* can be gathered from the QUSLJOB (list job) API.
* Qualify the Job Name:
C eval Job_Qual = CTJOB + CTUSER + CTJOBN
c z-add 256 Inf_Len
* Call the API to retrieve the WRKACTJOB info for this job:
C call 'QUSRJOBI'
C parm Job_Inf
C parm INF_Len
C parm 'JOBI0200' Api_Format 8
C parm Job_Qual 26
C parm *BLANKS Job_Int 16
c eval *inlr = *on
c return
| |
API - QDCRDEVD
Posted By: Jamie Flanary Contact |
The Retrieve Device Description (QDCRDEVD) API
retrieves information about a device description.
Formats: DEVD0100 - DEVD1800
D TotalC S 9S 0
D Len S 9B 0 Inz( 265 )
D Fmt S 8 Inz( 'MBRD0200' )
D FilNam S 20 Inz( 'LIBRARY FILE ' )
D MbrNam S 10 Inz( '*FIRST' )
D OvrPrs S 1 Inz( '0' )
D Error S 30
D Out DS 265
D BytRet 1 4B 0
D BytAvl 5 8B 0
D MbrName 29 38
D PFLF 137 137
D Total 141 144B 0
D DelRcd 145 148B 0
D NoMbrs 157 160B 0
C APIList PList
C Parm Out
C Parm Len
C Parm Fmt
C Parm FilNam
C Parm MbrNam
C Parm OvrPrs
C Parm Error
C*
C Call 'QUSRMBRD' APIList
C Z-Add Total TotalC
C BytRet Dsply
C BytAvl Dsply
C MbrName Dsply
C PFLF Dsply
C TotalC Dsply
C DelRcd Dsply
C NoMbrs Dsply
C Eval *InLR = *On
| |
API - QSNDDTAQ
Posted By: Jamie Flanary Contact |
D* InBound Data Structure
* DataQName = Name of Data Queue
* DataQLength = Length of Data Queue
* DataQData = Data to be placed onto DataQ
D DtaQDS DS
D DataQName 10 overlay(DtaQDs:1)
D DataQLength 5 0 overlay(DtaQDs:11)
D DataQData 1024 overlay(DtaQDS:16)
* DataQLib = Library contating DataQ (I use *libl
* but could be added to parm list)
D DataQLib s 10 inz('*LIBL')
* ReturnCode In this example is not used
D ReturnCode s 1
C Call 'QSNDDTAQ' DtaQParm 58
C if *IN58 = *on
C*=======> Execute your error handling logic here
C endif
c eval *inlr = *on
c return
C *inzsr begsr
C *entry plist
C parm DtaQDS
C parm ReturnCode
C DtaQParm plist
C parm DataQName
C parm DataQlib
C parm DataQLength
C parm DataQData
C endsr
| |
API - QRCVDTAQ
Posted By: Jamie Flanary Contact |
* DataQName = Name of Data Queue
* DataQLength = Length of Data Queue
* DataQWait = Time to wait for entry (-1 = forever)
* DataQData = Area to Store Retrived Data
D DtaQDS DS
D DataQName 10 overlay(DtaQDs:1)
D DataQLength 5 0 overlay(DtaQDs:11)
D DataQWait 5 0 overlay(DtaQDS:16)
D DataQData 1024 overlay(DtaQDS:21)
* DataQLib = Library contating DataQ (I use *libl
* but could be added to parm list)
D DataQLib s 10 inz('*LIBL')
* ReturnCode In this example is not used
D ReturnCode s 1
C Call 'QRCVDTAQ' DtaQParm 58
C if *IN58 = *on
C*=======> Execute your error handling logic here
C endif
c eval *inlr = *on
c return
C *inzsr begsr
C *entry plist
C parm DtaQDS
C parm ReturnCode
C DtaQParm plist
C parm DataQName
C parm DataQlib
C parm DataQLength
C parm DataQData
C parm DataQWait
C endsr
| |
API - QWCLOBJL
Posted By: Jamie Flanary Contact |
H DFTACTGRP(*NO) ACTGRP(*NEW) OPTION(*ALL)
D CrtUsrSpc PR ExtPgm('QUSCRTUS')
D UsrSpc 20A CONST
D ExtAttr 10A CONST
D InitSize 10I 0 CONST
D InitVal 1A CONST
D PublicAuth 10A CONST
D Text 50A CONST
D Replace 10A CONST
D ErrorCode 32766A options(*varsize)
D RtvPtrUS PR ExtPgm('QUSPTRUS')
D UsrSpc 20A CONST
D Pointer *
D LstObjLck PR ExtPgm('QWCLOBJL')
D UsrSpc 20A const
D Format 8A const
D Object 20A const
D ObjType 10A const
D Member 10A const
D ErrorCode 32766A options(*varsize)
D*****************************************************
D* API error code data structure
D*****************************************************
D dsEC DS
D* Bytes Provided (size of struct)
D dsECBytesP 1 4I 0 INZ(256)
D* Bytes Available (returned by API)
D dsECBytesA 5 8I 0 INZ(0)
D* Msg ID of Error Msg Returned
D dsECMsgID 9 15
D* Reserved
D dsECReserv 16 16
D* Msg Data of Error Msg Returned
D dsECMsgDta 17 256
D*****************************************************
D* List API generic header data structure
D*****************************************************
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*****************************************************
D* List Object Locks API format OBJL0100
D*****************************************************
D dsOL DS based(p_Entry)
D* Job Name
D dsOL_JobName 10A
D* Job User Name
D dsOL_UserName 10A
D* Job Number
D dsOL_JobNbr 6A
D* Lock State
D dsOL_LckState 10A
D* Lock Status
D dsOL_LckSts 10i 0
D* Lock Type
D dsOL_LckType 10i 0
D* Member (or *BLANK)
D dsOL_Member 10A
D* 1=Shared File, 0=Not Shared
D* (or 0=not applicable)
D dsOL_Share 1A
D* Lock Scope
D dsOL_LckScope 1A
D* Thread identifier
D dsOL_ThreadID 8A
D p_UsrSpc S *
D p_Entry S *
D Msg S 50A
D x S 10I 0
C *entry plist
c parm ObjName 10
C parm ObjLib 10
c parm ObjType 10
c parm Member 10
c eval *inlr = *on
c if %parms < 4
c eval Msg = 'Usage: objlock NAME LIB TYPE MBR'
c dsply Msg
c return
c endif
C*******************************************
C* Create a user space to store output of
C* the list object locks API
C*******************************************
c callp CrtUsrSpc('OBJLOCKS QTEMP': 'USRSPC':
c 1: x'00': '*ALL': 'Output of List ' +
c 'Object Locks API': '*YES': dsEC)
c if dsECBytesA > 0
c eval Msg = 'QUSCRTUS error ' + dsECMsgID
c dsply msg
c return
c endif
C*******************************************
C* Dump the Object Locks to the user space
C*******************************************
c callp LstObjLck('OBJLOCKS QTEMP': 'OBJL0100':
c ObjName+ObjLib: ObjType: Member: dsEC)
c if dsECBytesA > 0
c eval Msg = 'QWCLOBJL error ' + dsECMsgID
c dsply msg
c return
c endif
C*******************************************
C* Get a pointer to the user space
C*******************************************
c callp RtvPtrUS('OBJLOCKS QTEMP': p_UsrSpc)
C*******************************************
C* Read each entry in the list
C* and (for sake of example) display
C* the lock details
C*******************************************
c for x = 0 to (dsLHEntCnt-1)
c eval p_Entry = p_UsrSpc +
c (dsLHLstOff + (dsLHEntSiz*x))
c eval Msg = 'Job = '+%trimr(dsOL_JobNbr) +'/'+
c %trimr(dsOL_UserName)+'/'+
c %trimr(dsOL_JobName)
c Msg dsply
c eval Msg = 'Lock State = ' + dsOL_LckState
c Msg dsply
c select
c when dsOL_LckSts = 1
c eval Msg = 'Lock Status = HELD'
c when dsOL_LckSts = 2
c eval Msg = 'Lock Status = WAIT'
c when dsOL_LckSts = 2
c eval Msg = 'Lock Status = REQ'
c endsl
c Msg dsply
c select
c when dsOL_LckType = 1
c eval Msg = 'Lock Type = OBJECT'
c when dsOL_LckType = 2
c eval Msg = 'Lock Type = MBR CTL BLK'
c when dsOL_LckType = 3
c eval Msg = 'Lock Type = MBR ACC PTH'
c when dsOL_LckType = 3
c eval Msg = 'Lock Type = MBR DATA'
c endsl
c Msg dsply
c eval Msg = 'Member = ' + dsOL_Member
c Msg dsply
c if dsOL_Share = '1'
c eval Msg = 'Share lock = YES'
c else
c eval Msg = 'Share lock = NO'
c endif
c Msg dsply
c if dsOL_LckScope = '1'
c eval Msg = 'Scope = THREAD'
c else
c eval Msg = 'Scope = JOB'
c endif
c Msg dsply
c eval Msg = '<< PRESS ENTER >>'
c dsply Msg
c endfor
| |
API - QSYGETPH
Posted By: Jamie Flanary Contact |
*this api validates an as400 username and password:
DWkUser S 10A
DWKPassword S 10A
DProfileHandle S 12A
D*
DQUSEC DS
D* Qus EC
D QUSBPRV 1 4B 0
D* Bytes Provided
D QUSBAVL 5 8B 0
D* Bytes Available
D QUSEI 9 15
D* Exception Id
D QUSERVED 16 16
D* Reserved
D ERRC0100 17 274 Varying
.
.
.
C*
C Call 'QSYGETPH'
C Parm WKUser
C Parm WKPassword
C Parm ProfileHandle
C Parm QUSEC
C*
C If QUSBAVL > 0
C Eval Error = *ON
C Endif
| |
API - QUSLMBR
Posted By: JimmyOctane Contact |
*------------------------------------------------------
* Program Name:
* Description : retrieve members
* Written On : 03/2004
*
*
* Modification
* ~~~~~~~~~~~~
* Date Description
* ~~~~~~~~ ~~~~~~~~~~~
*
*------------------------------------------------------
H Option(*SrcStmt: *NoDebugIO) DftActGRP(*No)
À*
À* Field Definitions
À*
d ISOdate s D
d ARC S 1 DIM(7000)
d AOF S 8 DIM(501)
*
d GENDS DS
d SIZINP 113 116B 0
d OFFLST 125 128B 0
d NUMLST 133 136B 0
d SIZENT 137 140B 0
d INPUT DS
d USRSPC 1 20
d SPCNAM 1 10
d SPCLIB 11 20
d LIST DS
d OBJNML 1 10
d LIBNML 11 20
d OBJTYL 21 30
d TXTDSC 42 91
d OBJOWN 113 122
d OBJSIZ 577 580B 0
d OJSZMT 581 584B 0
d ERROR DS INZ
d BYTPRV 1 4B 0
d BYTAVA 5 8B 0
d MSGID 9 15
d ERR### 16 16
d MSGDTA 17 116
d LAO DS 300
d EL 1 4B 0
d EO 5 8B 0
d RCVVR1 DS 7000
d ENTLOF DS 408
d SFINDX DS 96 INZ
d SFNAME 1 10
d SFTYPE 11 20
d SFSIZE 21 30 0
d SFDESC 31 76
d SFOWNR 77 86
d SFLIB 87 96
d IENTRY DS 126 INZ
d KEYFLD 1 30
d KEY10 1 10
d LIBOBJ 11 30
d DSINDX 31 126
d DS
d STRPOS 1 4B 0
d STRLEN 5 8B 0
d LENSPC 9 12B 0
d ENTLEN 13 16B 0
d KEYLEN 17 20B 0
d NBRADD 21 24B 0
d INSTYP 25 28B 0
d NBRENT 29 32B 0
d RCVVRL 33 36B 0
d ENTLLN 37 40B 0
d NBRRTN 41 44B 0
d MAXENT 45 48B 0
d SEARTY 49 52B 0
d SERLEN 53 56B 0
d SEROFF 57 60B 0
d INDEXN 61 80
d INDNAM 61 70
d INDLIB 71 80
*
d VALSPC s 1
d ATSPC s 10
d TXTSPC s 50
d RPLSPC s 10
d ATRSPC s 10
d Format S 8A Inz('MBRL0200')
d AllMbrs S 10A Inz('*ALL ')
d OvrDbf S 1A Inz('1')
d DataBase S 20A Inz('STAPE QTEMP ')
d GenLen S 9B 0
d*StrPos S 9B 0
d RtvLen S 9B 0
d RcvLen S 9B 0
d Count S 15 0
d OutPut S 1A
d Member S 10
d AUTSPC S 10
À*
À* Copy book API data structures
À*
d/COPY QSYSINC/QRPGLESRC,QUSRUSAT
d/COPY QSYSINC/QRPGLESRC,QUSLMBR
d/COPY QSYSINC/QRPGLESRC,QUSGEN
À*
À* Create user space
À*
c Eval SPCNAM = 'SPMEMBER'
c Eval SPCLIB = 'QTEMP'
À*
c CALL 'QUSCRTUS'
c PARM USRSPC
c PARM *BLANKS ATRSPC
c PARM 2048 LENSPC
c PARM *BLANKS VALSPC
c PARM '*CHANGE' AUTSPC
c PARM *BLANKS TXTSPC
c PARM '*YES' RPLSPC
c PARM ERROR
À*
À* Create Member List
À*
C Call 'QUSLMBR'
C Parm USRSPC
C Parm Format
C Parm Database
C Parm AllMbrs
C Parm OvrDbf
C Parm ERROR
À*
À* Set Values for Generic Header
À*
C Eval GenLen = 140
C Eval StrPos = 1
À*
À* Retreive Number of Entries, Offset, and the size of each entry
À*
C Call 'QUSRTVUS'
C Parm USRSPC
C Parm StrPos
C Parm GenLen
C Parm QUSH0100
C Parm ERROR
À*
À* Check the Generic Header data structure for number of list entr
À* offset to list entries, and size of each list entry
À*
c Eval StrPos = ( QUSOLD + 1 )
c Eval RtvLen = QUSSEE
c Eval RcvLen = 209
c Eval Count = 1
À*
À* Retreive All Members
À*
c DoW Count <= QUSNBRLE
À*
c Call 'QUSRTVUS'
c Parm USRSPC
c Parm StrPos
c Parm RtvLen
c Parm QUSL0200
c Parm ERROR
À*
c Eval StrPos = QUSSEE + StrPos
c Eval Count = Count + 1
À*
À* process members here
À*
c movel(p) QUSMN01 Member
À*
c EndDo
À*
À* Delete User Space
À*
c Call 'QUSDLTUS'
c Parm USRSPC
c Parm ERROR
À*
c eval *inlr = *On
| |
API - QWCRSVAL
Posted By: JimmyOctane Contact |
Use QWCRSVAL API to get the serial number
D QWCRSVAL PR ExtPgm('QWCRSVAL')
D p_Rcvr Like(w_Rcvr)
D p_RcvrLngth Like(w_RcvrLngth)
D p_NbrToRtv Like(w_NbrToRtv)
D p_SysVal Like(w_SysVal)
D p_Error Like(DS_APIError)
************************************************************************
**
* #RtvSrlNbr - Retrieve the system Serial Number
*
************************************************************************
**
P #RtvSrlNbr B Export
D PI 8a
* Work Fields used by Procedure
D w_SrlNbr S 8
D w_Rcvr S 36a
D w_RcvrLngth S 10i 0 inz(%len(w_Rcvr))
D w_NbrToRtv S 10i 0 inz(1)
D w_SysVal S 10a inz('QSRLNBR')
* Prototypes for calls
D QWCRSVAL PR ExtPgm('QWCRSVAL')
D p_Rcvr Like(w_Rcvr)
D p_RcvrLngth Like(w_RcvrLngth)
D p_NbrToRtv Like(w_NbrToRtv)
D p_SysVal Like(w_SysVal)
D p_Error Like(DS_APIError)
D DS_SysValTbl DS
D d_ValsRtn 10i 0
D d_Offset 10i 0
D D_Align 4a
D d_SysVal 10a
D d_ValType 1a
D d_InfoSts 1a
D d_DtaLngth 10i 0
D d_Data 10a
C Reset DS_APIError
C CallP QWCRSVAL(w_Rcvr :
C w_RcvrLngth :
C w_NbrToRtv :
C w_SysVal :
C DS_APIError )
C Eval DS_SysValTbl = w_Rcvr
C Eval w_SrlNbr = %subst(d_Data:1:d_DtaLngth)
C Return w_SrlNbr
P #RtvSrlNbr E
| |
API - QUSRJOBI
Posted By: JimmyOctane Contact |
*------------------------------------------------------
* Retrieve current user profile information.
*------------------------------------------------------
H Option(*SrcStmt: *NoDebugIO) DftActGRP(*No)
*
* Field Definitions.
*
d ISOdate S D
d ErrorCode S 8 inz(X'0000000000000000')
d RCVVARLN S 4 inz(X'00000100')
d FORMAT S 8 inz('JOBI0600')
d JOBQ S 26 inz('*')
d JOBID S 16
*
dTheData DS
*
* Bytes Return
*
d QUSBR05 1 4B 0
*
* Bytes Avail
*
d QUSBA05 5 8B 0
*
* Job Name
*
d QUSJN08 9 18
*
* User Name
*
d QUSUN07 19 28
*
* Job Number
*
d QUSJNBR07 29 34
*
* Int Job ID
*
d QUSIJID05 35 50
*
* Job Status
*
d QUSJS14 51 60
*
* Job Type
*
d QUSJT08 61 61
*
* Job Subtype
*
d QUSJS15 62 62
*
* Job Switch
*
d QUSJS16 63 70
*
* End Status
*
d QUSES00 71 71
*
* Subsys Name
*
d QUSSN00 72 81
*
* Subsys Lib
*
d QUSSL06 82 91
*
* Curr Usrprf Name
*
d QUSCUN 92 101
*
* Dbcs Enabled
*
d QUSDE 102 102
*
* Exit Key
*
d QUSEK 103 103
*
* Cancel Key
*
d QUSCK00 104 104
*
* Product Return Code
*
d QUSPRC 105 108B 0
*
* User Return Code
*
d QUSURC 109 112B 0
*
* Program Return Code
*
d QUSPGMRC 113 116B 0
*
* Special Environment
*
d QUSSE02 117 126
*
* Device Name
*
d QUSDN 127 136
*
* Group Profile Name
*
d QUSGPN 137 146
d QUSGRP 10 DIM(00015)
d QUSGN00 10 OVERLAY(QUSGRP:00001)
*
* Job User ID
*
d QUSJUID 297 306
*
* Job User ID Setting
*
d QUSJUIDS 307 307
*
c call 'QUSRJOBI'
c parm TheData
c parm RCVVARLN
c parm FORMAT
c parm JOBQ
c parm JOBID
c parm ErrorCode
*
c eval *Inlr = *on
| |
API - QUSROBJD - OBJD0100
Posted By: JimmyOctane Contact |
D ErrorDs DS INZ
D BytesProvd 1 4B 0
D BytesAvail 5 8B 0
D MessageId 9 15
D ERR### 16 16
D MessageDta 17 116
D Receiver S 100
D ReceivrLen S 4B 0 INZ(100)
D Object S 10
D ObjLibrary S 10
D ObjType S 8
D ExistYesNo S 1
D FileLib S 20
D FileFormat S 8 INZ('OBJD0100')
C *ENTRY PLIST
C PARM Object
C PARM ObjLibrary
C PARM ObjType
C PARM ExistYesNo
C ObjLibrary IFEQ *BLANKS
C EVAL ObjLibrary = 'LIBL'
C ENDIF
C EVAL FileLib = Object + ObjLibrary
*
* Attempt to retrieve object description
*
C CALL 'QUSROBJD'
C PARM Receiver
C PARM ReceivrLen
C PARM FileFormat
C PARM FileLib
C PARM ObjType
C PARM ErrorDs
C EVAL ExistYesNo = 'Y'
C MessageId IFNE *BLANKS
C EVAL ExistYesNo = 'N'
C ENDIF
C EVAL *InLr = *ON
| |
API - QUSROBJD - OBJD0300
Posted By: JimmyOctane Contact |
D ErrorDs DS INZ
D BytesProvd 1 4B 0 INZ(116)
D BytesAvail 5 8B 0
D MessageId 9 15
D ERR### 16 16
D MessageDta 17 116
D DS
D Receiver 206
D DateSaved 13 OVERLAY(Receiver:194)
D ReceiveLen S 4B 0 INZ(206)
D FileLib S 20
D PassInFile S 10
D PassInLib S 10
D PassDateSv S 13
D FormatName S 8 INZ('OBJD0300')
D ObjectType S 10 INZ('*FILE')
C *ENTRY PLIST
C PARM PassInFile
C PARM PassInLib
C PARM PassDateSv
C EVAL FileLib = PassInFile + PassInLib
C CALL 'QUSROBJD'
C PARM Receiver
C PARM ReceiveLen
C PARM FormatName
C PARM FileLib
C PARM ObjectType
C PARM ErrorDs
C IF DateSaved <> *BLANKS
C EVAL PassDateSv = DateSaved
C ENDIF
C EVAL *InLr = *ON
| |
API - QUSROBJD
Posted By: JimmyOctane Contact |
À*------------------------------------------------------
À* Program Name:
À* Description : get user name
À* Written On : 05/2004
À*
À*
À* Modification
À* ~~~~~~~~~~~~
À* Date Description
À* ~~~~~~~~ ~~~~~~~~~~~
À*
À*------------------------------------------------------
H Option(*SrcStmt: *NoDebugIO) DftActGRP(*No)
À*
À* Program Info
À*
d SDS
d @PGM 001 010
d @PARMS 037 039 0
d @MSGID 40 46
d @MSGDTA 91 170
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
À*
À* Field Definitions.
À*
d ISOdate S D
À*
À* Check name unique when add save processed (F6)
À*
d CheckObject S 19 Dim(9999)
À*
À* Some working environment
À* ~~~~~~~~~~~~~~~~~~~~~~~~
D ObjNam s 10a
D ObjLib s 10a
D ObjTyp s 10a
**-- Api error data structure: ----------------------------------
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- Object description structure OBJD0200: ---------------------
D RoData Ds
D RoBytRtn 10i 0
D RoBytAvl 10i 0
D RoObjNam 10a
D RoObjLib 10a
D RoObjTypRt 10a
D RoObjLibRt 10a
D RoObjASP 10i 0
D RoObjOwn 10a
D RoObjDmn 2a
D RoObjCrtDts 13a
D RoObjChgDts 13a
D RoExtAtr 10a
D RoTxtDsc 50a
D RoSrcF 10a
D RoSrcLib 10a
D RoSrcMbr 10a
**-- Retrieve object description: -------------------------------
D RtvObjD Pr ExtPgm( 'QUSROBJD' )
D RoRcvVar 32767a Options( *VarSize )
D RoRcvVarLen 10i 0 Const
D RoFmtNam 8a Const
D RoObjNamQ 20a Const
D RoObjTyp 10a Const
D RoError 32767a Options( *VarSize )
À*
dTheData DS
À*
À* Bytes Return
À*
d QUSBR05 1 4B 0
À*
À* Bytes Avail
À*
d QUSBA05 5 8B 0
À*
À* Job Name
À*
d QUSJN08 9 18
À*
À* User Name
À*
d QUSUN07 19 28
À*
À* Job Number
À*
d QUSJNBR07 29 34
À*
À* Int Job ID
À*
d QUSIJID05 35 50
À*
À* Job Status
À*
d QUSJS14 51 60
À*
À* Job Type
À*
d QUSJT08 61 61
À*
À* Job Subtype
À*
d QUSJS15 62 62
À*
À* Job Switch
À*
d QUSJS16 63 70
À*
À* End Status
À*
d QUSES00 71 71
À*
À* Subsys Name
À*
d QUSSN00 72 81
À*
À* Subsys Lib
À*
d QUSSL06 82 91
À*
À* Curr Usrprf Name
À*
d QUSCUN 92 101
À*
À* Dbcs Enabled
À*
d QUSDE 102 102
À*
À* Exit Key
À*
d QUSEK 103 103
À*
À* Cancel Key
À*
d QUSCK00 104 104
À*
À* Product Return Code
À*
d QUSPRC 105 108B 0
À*
À* User Return Code
À*
d QUSURC 109 112B 0
À*
À* Program Return Code
À*
d QUSPGMRC 113 116B 0
À*
À* Special Environment
À*
d QUSSE02 117 126
À*
À* Device Name
À*
d QUSDN 127 136
À*
À* Group Profile Name
À*
d QUSGPN 137 146
d QUSGRP 10 DIM(00015)
d QUSGN00 10 OVERLAY(QUSGRP:00001)
À*
À* Job User ID
À*
d QUSJUID 297 306
À*
À* Job User ID Setting
À*
d QUSJUIDS 307 307
À*
À* Make sure that the tape drive exists. jamie
À*
c Eval ObjNam = %Trim(@USER)
c Eval ObjLib = '*LIBL'
c Eval ObjTyp = '*USRPRF'
À*
c CallP rtvObjD( RoData
c : %Size( RoData )
c : 'OBJD0200'
c : ObjNam + ObjLib
c : ObjTyp
c : ApiError
c )
À*
c eval *INLR = *On
À*-----------------------------------------------
À* *INZSR - Initial one time run subroutine
À*-----------------------------------------------
c *INZSR begsr
c endsr
À*-----------------------------------------------
| |
API - QBNRMODI
Posted By: JimmyOctane Contact |
d SDS
d @PGM 001 010
d @PARMS 037 039 0
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
*==============================================
* QBNRMODI API to Retrieve module info
*==============================================
*
* Standard Parameters for QBNRMODI
* (RETRIEVE MODULE INFORMATION)
*
D RM_PARM DS INZ
D RM_RCV 1 170 RECEIVER VARIABLE
D RM_MODNAME 9 18 MODULE NAME
D RM_MODLIB 19 28 MODULE LIBRARY
D RM_MODATTR 29 38 MODULE ATTRIBUTE
D RM_SRCFIL 52 61 SOURCE FILE
D RM_SRCLIB 62 71 SOURCE LIBRARY
D RM_SRCMBR 72 81 SOURCE MEMBER
D RM_TEXT 121 170 TEXT DESCRIPTION
D RM_RCV_LEN 171 174B 0 LENGTH OF RCV VAR
D RM_FORMAT 175 182 FORMAT NAME
D RM_PGM_LIB 183 202 PGM NAME & LIBRARY
D RM_PGM 183 192 PROGRAM NAME
D RM_LIB 193 202 PROGRAM LIBRARY
*
* Standard API error data structure
*
d APIERR DS INZ
d AEBYPR 1 4B 0
d AEBYAV 5 8B 0
d AEEXID 9 15
d AEEXDT 16 116
*
* Define Variables
*
d InLibrary S 10
d InModule S 10
*
c clear RM_PARM
c eval RM_RCV_LEN = 170
c eval RM_FORMAT = 'MODI0100'
c eval RM_PGM = InModule
c eval RM_LIB = InLibrary
c clear APIERR
c eval AEBYPR = 116
*
c call 'QBNRMODI'
c parm RM_RCV
c parm RM_RCV_LEN
c parm RM_FORMAT
c parm RM_PGM_LIB
c parm APIERR
*
c eval *INLR = *On
*
*==============================================
* *Inzsr - Initial onetime subroutine
*==============================================
csr *Inzsr begsr
*
c *Entry Plist
c parm InLibrary
c parm InModule
*
c endsr
*==============================================
| |
API - QCLRPGMI
Posted By: JimmyOctane Contact |
À * Ä
À * Program Info Ä
À * Ä
d SDS
d @PGM 001 010
d @PARMS 037 039 0
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
*==============================================
* QCLRPGMI API to Retrieve program info
*==============================================
*
* Standard API error data structure
*
d APIERR DS INZ
d AEBYPR 1 4B 0
d AEBYAV 5 8B 0
d AEEXID 9 15
d AEEXDT 16 116
*
* Standard parameters for QCLRPGMI API
* (Retrieve Program Information) API
*
d RP_PARM DS INZ
d RP_RCV 1 416 RECEIVER VARIABLE
d RP_PGMNAME 9 18 PROGRAM NAME
d RP_PGMLIB 19 28 PROGRAM LIBRARY
d RP_PGMATTR 39 48 PROGRAM ATTRIBUTE
d RP_TEXT 111 160 TEXT DESCRIPTION
d RP_MODULES 413 416B 0 NUMBER OF MODULES
d RP_RCV_LEN 417 420B 0 LENGTH OF RCV VAR
d RP_FORMAT 421 428 FORMAT NAME
d RP_PGM_LIB 429 448 PGM NAME & LIBRARY
d RP_PGM 429 438 PROGRAM NAME
d RP_LIB 439 448 PROGRAM LIBRARY
*
* Define Variables
*
d InLibrary S 10
d InProgram S 10
*
c clear RP_parm
c eval RP_RCV_LEN = 416
c eval RP_FORMAT = 'PGMI0100'
c eval RP_PGM = InProgram
c eval RP_LIB = InLibrary
c clear APIERR
c eval AEBYPR = 116
*
c call 'QCLRPGMI'
c parm RP_RCV
c parm RP_RCV_LEN
c parm RP_FORMAT
c parm RP_PGM_LIB
c parm APIERR
*
c eval *INLR = *On
*
*==============================================
* *Inzsr - Initial onetime subroutine
*==============================================
csr *Inzsr begsr
*
c *Entry Plist
c parm InLibrary
c parm InProgram
*
c endsr
*==============================================
| |
API - QWCRSVAL
Posted By: Ron Hawkins Contact |
DQWCRDR00 DS
D* Qwc Rsval Data Rtnd
D QWCNSVR 1 4B 0
D* Number Sys Vals Rtnd
D QWCOSVT 5 8B 0
D*
D Data 1 dim(2096)
D QWCSV00 DS 2096
D QWCSV01 10 OVERLAY(QWCSV00:00001)
D QWCTD01 1 OVERLAY(QWCSV00:00011)
D QWCIS03 1 OVERLAY(QWCSV00:00012)
D QWCLD01 9B 0 OVERLAY(QWCSV00:00013)
D QWCDATA01 2080 OVERLAY(QWCSV00:00017)
DQUSEC DS 116 inz
D QUSBPRV 1 4B 0 inz(116)
D QUSBAVL 5 8B 0 inz(0)
D QUSEI 9 15
D QUSERVED 16 16
D QUSED01 17 116
D LockedCon c 'System value was locked'
D MoveInd S 5 0
D NbrOfVals S 10i 0 Inz(1)
D OutData s 50
D ReceiveLen S 10i 0 Inz(2104)
D SysValue s 10
DBinaryCvt DS
D BinaryNbr 1 4B 0
c *entry Plist
c Parm SysValue
* Call the api to get the information you want
C Call 'QWCRSVAL'
C Parm QwcRdr00
C Parm ReceiveLen
C Parm NbrofVals
C Parm SysValue
C Parm QusEc
* Process the data from the API
c Eval MoveInd = Qwcosvt - 7
c Movea Data(MoveInd) QwcSV00
c Select
* Value was locked, couldn't get it
c When QwcIs03 = 'L'
c Movel LockedCon OutData
* Character data
c When QwcTd01 = 'C'
c Movel QwcData01 OutData
* Binary data
c When QwcTd01 = 'B'
c Movel QwcData01 BinaryCvt
c Movel BinaryNbr OutData
c Endsl
* Display system value
c OutData dsply
c Eval *inlr = *on
| |
API - QCLRPGMI
Posted By: JimmyOctane Contact |
À * Ä
À * Program Info Ä
À * Ä
d SDS
d @PGM 001 010
d @PARMS 037 039 0
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
*==============================================
* QCLRPGMI API to Retrieve program info
*==============================================
*
* Standard API error data structure
*
d APIERR DS INZ
d AEBYPR 1 4B 0
d AEBYAV 5 8B 0
d AEEXID 9 15
d AEEXDT 16 116
*
* Standard parameters for QCLRPGMI API
* (Retrieve Program Information) API
*
d RP_PARM DS INZ
d RP_RCV 1 416 RECEIVER VARIABLE
d RP_PGMNAME 9 18 PROGRAM NAME
d RP_PGMLIB 19 28 PROGRAM LIBRARY
d RP_PGMATTR 39 48 PROGRAM ATTRIBUTE
d RP_TEXT 111 160 TEXT DESCRIPTION
d RP_MODULES 413 416B 0 NUMBER OF MODULES
d RP_RCV_LEN 417 420B 0 LENGTH OF RCV VAR
d RP_FORMAT 421 428 FORMAT NAME
d RP_PGM_LIB 429 448 PGM NAME & LIBRARY
d RP_PGM 429 438 PROGRAM NAME
d RP_LIB 439 448 PROGRAM LIBRARY
*
* Define Variables
*
d InLibrary S 10
d InProgram S 10
*
c clear RP_parm
c eval RP_RCV_LEN = 416
c eval RP_FORMAT = 'PGMI0100'
c eval RP_PGM = InProgram
c eval RP_LIB = InLibrary
c clear APIERR
c eval AEBYPR = 116
*
c call 'QCLRPGMI'
c parm RP_RCV
c parm RP_RCV_LEN
c parm RP_FORMAT
c parm RP_PGM_LIB
c parm APIERR
*
c eval *INLR = *On
*
*==============================================
* *Inzsr - Initial onetime subroutine
*==============================================
csr *Inzsr begsr
*
c *Entry Plist
c parm InLibrary
c parm InProgram
*
c endsr
*==============================================
| |
API - QUSLOBJ
Posted By: jimmy octane Contact |
*===================================================
* PROGRAM - @@SPACE
* PURPOSE - dump objects (DSPOBJD) to userspace
* WRITTEN -
* AUTHOR - jamie
*
* PROGRAM DESCRIPTION
* This program will dump objects into a userspace
*
*
* INPUT PARAMETERS
* Description Type Size How Used
* ----------- ---- ---- --------
* InLibary Char 10 Library to search for objects
* InType Char 10 Type of objects to dump
*
* INDICATOR USAGE
* 03 - Cancel current screen and return to previous screen
* 30 - SFLCLR
* 31 - SFLDSP
* 32 - SFLDSPCTL
* 33 - SFLEND
*
*===================================================
*
* Program Info
*
d SDS
d @PGM 1 10
d @PARMS 37 39 0
d @JOB 244 253
d @USER 254 263
d @JOB# 264 269 0
*
* Field Definitions.
*
d AllText s 10 Inz('*ALL')
d CmdString s 256
d CmdLength s 15 5
d Count s 4 0
d Format s 8
d GenLen s 8
d InLibrary s 10
d InType s 10
d ObjectLib s 20
d SpaceVal s 1 inz(*BLANKS)
d SpaceAuth s 10 inz('*CHANGE')
d SpaceText s 50 inz(*BLANKS)
d SpaceRepl s 10 inz('*YES')
d SpaceAttr s 10 inz(*BLANKS)
d UserSpaceOut s 20
À * Ä
À * GenHdr Ä
À * Ä
d GenHdr ds inz
d OffSet 1 4B 0
d NumEnt 9 12B 0
d Lstsiz 13 16B 0
À * Ä
À * Data structures Ä
À * Ä
d GENDS ds
d OffsetHdr 1 4B 0
d NbrInList 9 12B 0
d SizeEntry 13 16B 0
*
*
*
d HeaderDs ds
d OutFileNam 1 10
d OutLibName 11 20
d OutType 21 25
d OutFormat 31 40
d RecordLen 41 44B 0
*
* API Error Data Structure
*
d ErrorDs DS INZ
d BytesPrv 1 4B 0
d BytesAvl 5 8B 0
d MessageId 9 15
d ERR### 16 16
d MessageDta 17 116
*
* Create userspace datastructure
*
d DS
d StartPosit 1 4B 0
d StartLen 5 8B 0
d SpaceLen 9 12B 0
d ReceiveLen 13 16B 0
d MessageKey 17 20B 0
d MsgDtaLen 21 24B 0
d MsgQueNbr 25 28B 0
*
* Date structure for retriving userspace info
*
d InputDs DS
d UserSpace 1 20
d SpaceName 1 10
d SpaceLib 11 20
d InpFileLib 29 48
d InpFFilNam 29 38
d InpFFilLib 39 48
d InpRcdFmt 49 58
*
d ObjectDs ds
d Object 10
d Library 10
d ObjectType 10
d InfoStatus 1
d ExtObjAttrib 10
d Description 50
À * Ä
* Create a userspace
*
c exsr $QUSCRTUS
*
c eval ObjectLib = AllText + InLibrary
*
* List all the objects to the user space
*
c eval Format = 'OBJL0200'
*
c call(e) 'QUSLOBJ'
c parm Userspace UserSpaceOut
c parm Format
c parm ObjectLib
c parm InType
*
* Retrive header entry and process the user space
*
c eval StartPosit = 125
c eval StartLen = 16
*
* Retrive header entry and process the user space
*
c call 'QUSRTVUS'
c parm UserSpace UserSpaceOut
c parm StartPosit
c parm StartLen
c parm GENDS
*
c eval StartPosit = OffsetHdr + 1
c eval StartLen = %size(ObjectDS)
*
*
À * Do for number of fields Ä
*
B1 c do NbrInList
*
c call(e) 'QUSRTVUS'
c parm UserSpace UserSpaceOut
c parm StartPosit
c parm StartLen
c parm ObjectDs
*
c eval StartPosit = StartPosit + SizeEntry
c enddo
*
c eval *Inlr = *On
*===============================================
* $QUSCRTUS - API to create user space
*===============================================
c $QUSCRTUS begsr
*
* Create a user space named ListObjects in QTEMP.
*
c Eval BytesPrv = 116
c movel(p) 'LISTOBJECTS' SpaceName
c movel(p) 'QTEMP' SpaceLib
*
* Create the user space
*
c call(e) 'QUSCRTUS'
c parm UserSpace UserSpaceOut
c parm SpaceAttr
c parm 4096 SpaceLen
c parm SpaceVal
c parm SpaceAuth
c parm SpaceText
c parm SpaceRepl
c parm ErrorDs
*
c endsr
*=================================================
* *Inzsr - One time run House keeping subroutine
*=================================================
c *Inzsr begsr
*
c *entry plist
c parm InLibrary
c parm InType
*
c endsr
*==============================================
| |
API - QHFRTVAT
Posted By: jimmy octane Contact |
H* ***************************************************************
H* *
H* MODULE: ERRCODE *
H* *
H* LANGUAGE: RPG *
H* *
H* FUNCTION: THIS APPLICATION DEMONSTRATES THE USE OF THE *
H* ERROR CODE PARAMETER. *
H* *
H* APIs USED: QHFRTVAT, QHFCRTDR *
H* *
H* ***************************************************************
H* ***************************************************************
H* *
H* THIS PROGRAM DOES SOME SIMPLE VERIFICATION ON AN HFS *
H* DIRECTORY. THE QHFRTVAT API IS USED TO VERIFY THE EXISTENCE *
H* OF THE SPECIFIED DIRECTORY. IF THE DIRECTORY DOES NOT EXIST, *
H* AN ATTEMPT IS MADE TO CREATE THE DIRECTORY. *
H* *
H* THERE ARE THREE PARAMETERS TO THIS PROGRAM *
H* *
H* 1 INPUT PATHNM - NAME OF DIRECTORY *
H* 2 INPUT PATHLN - LENGTH OF PATHNM PARAMETER *
H* 3 OUTPUT SUCCES - INDICATES SUCCESS OR FAILURE *
H* '0' SUCCESS *
H* '1' FAILURE *
H* ***************************************************************
ISUCCES DS
I B 1 40RETCOD
IPLENG DS
I B 1 40PATHLN
IBINS DS
I B 1 40RETDTA
I B 5 80ATTRLN
IERROR DS
I B 1 40BYTPRV
I B 5 80BYTAVA
I 9 15 ERRID
I 16 16 ERR###
I 17 272 INSDTA
C *ENTRY PLIST
C PARM PATHNM 80
C PARM PLENG
C PARM SUCCES
C*
C* INITIALIZE BYTES PROVIDED AND THE ATTRIBUTE LENGTH VARIABLE
C*
C Z-ADD272 BYTPRV
C Z-ADD0 ATTRLN
C*
C* RETRIEVE DIRECTORY ENTRY ATTRIBUTES
C*
C CALL 'QHFRTVAT'
C PARM PATHNM
C PARM PATHLN
C PARM ATTR 1
C PARM ATTRLN
C PARM ATTR
C PARM ATTRLN
C PARM RETDTA
C PARM ERROR
C*
C* CHECK FOR DIRECTORY NOT FOUND OR FILE NOT FOUND ERRORS.
C* IF WE RECEIVE ONE OF THESE THIS IS THE INDICATION THAT
C* WE CAN TRY TO CREATE THE DIRECTORY.
C*
C BYTAVA IFEQ *ZERO
C Z-ADD0 RETCOD
C ELSE
C 'CPF1F02' IFEQ ERRID
C 'CPF1F22' OREQ ERRID
C* *************************************************************
C* THERE IS NO NEED TO REINITIALIZE THE ERROR CODE PARAMETER.
C* ONLY BYTES PROVIDED IS INPUT TO THE API; IT WILL RESET THE
C* ERROR CODE PARAMETER FOR US. AFTER THE CALL TO QHFCRTDR,
C* BYTES AVAILABLE WILL EITHER BE 0 IF SUCCESSFUL OR NONZERO
C* IF THE CREATE FAILS. WE DO NOT HAVE TO WORRY ABOUT THE
C* PREVIOUS ERROR CODE BEING left IN THE ERROR CODE PARAMETER.
C* *************************************************************
C CALL 'QHFCRTDR'
C PARM PATHNM
C PARM 20 PATHLN
C PARM ATTR 1
C PARM 0 ATTRLN
C PARM ERROR
C BYTAVA IFEQ *ZERO
C Z-ADD0 RETCOD
C ELSE
C Z-ADD1 RETCOD
C END
C*
C ELSE
C Z-ADD1 RETCOD
C END
C END
C*
C* PROGRAM END
C*
C SETON LR
| |
API - QUSRJOBI
Posted By: Jimmy Octane Contact |
fSOMEDDS cf e WORKSTN usropn
*
* Data structure(s) for checking if job
* is BATCH or interactive. Check dsJobType
* I=Interactive B=Batch
*
d RcvVar s 32766A
d RcvVarLen s 10i 0
d Format s 8A
d QualJob s 26A
d InternJob s 16A
d ErrorCode s 32766A
d dsJob DS
d dsJobBytesRtn 10I 0
d dsJobBytesAvl 10I 0
d dsJobName 10A
d dsJobUser 10A
d dsJobNumber 6A
d dsJobIntern 16A
d dsJobStatus 10A
d dsJobType 1A
d dsJobSubtype 1A
d dsJobReserv1 2A
d dsJobRunPty 10I 0
d dsJobTimeSlc 10I 0
d dsJobDftWait 10I 0
d dsJobPurge 10A
*
* Check to see if job is batch or interactive
*
c eval RcvVarLen = %Size(DsJob)
*
c call(e) 'QUSRJOBI'
c parm DsJob
c parm RcvVarLen
c parm 'JOBI0100' Format
c parm '*' QualJob
c parm *Blanks InternJob
*
* If interactive job then open the display file
*
c select
*
* Interactive
*
c when DSJobType = 'I'
c if not%open(SOMEDDS)
c open SOMEDDS
c endif
*
* Batch
*
c when DSJobType = 'B'
*
c endsl
*
c eval *inlr = *on
*
| |
API - Get Web page info on as400 Green Screen
Posted By: Patel Contact |
***** I Found This Codes On some website I Do not claim any credit ******
H DFTACTGRP(*NO) ACTGRP(*NEW)
D getservbyname PR * ExtProc('getservbyname')
D service_name * value options(*string)
D protocol_name * value options(*string)
D p_servent S *
D servent DS based(p_servent)
D s_name *
D s_aliases *
D s_port 10I 0
D s_proto *
D inet_addr PR 10U 0 ExtProc('inet_addr')
D address_str * value options(*string)
D INADDR_NONE C CONST(4294967295)
D inet_ntoa PR * ExtProc('inet_ntoa')
D internet_addr 10U 0 value
D p_hostent S *
D hostent DS Based(p_hostent)
D h_name *
D h_aliases *
D h_addrtype 10I 0
D h_length 10I 0
D h_addr_list *
D p_h_addr S * Based(h_addr_list)
D h_addr S 10U 0 Based(p_h_addr)
D gethostbyname PR * extproc('gethostbyname')
D host_name * value options(*string)
D socket PR 10I 0 ExtProc('socket')
D addr_family 10I 0 value
D type 10I 0 value
D protocol 10I 0 value
D AF_INET C CONST(2)
D SOCK_STREAM C CONST(1)
D IPPROTO_IP C CONST(0)
D connect PR 10I 0 ExtProc('connect')
D sock_desc 10I 0 value
D dest_addr * value
D addr_len 10I 0 value
D p_sockaddr S *
D sockaddr DS based(p_sockaddr)
D sa_family 5I 0
D sa_data 14A
D sockaddr_in DS based(p_sockaddr)
D sin_family 5I 0
D sin_port 5U 0
D sin_addr 10U 0
D sin_zero 8A
D send PR 10I 0 ExtProc('send')
D sock_desc 10I 0 value
D buffer * value
D buffer_len 10I 0 value
D flags 10I 0 value
D recv PR 10I 0 ExtProc('recv')
D sock_desc 10I 0 value
D buffer * value
D buffer_len 10I 0 value
D flags 10I 0 value
D close PR 10I 0 ExtProc('close')
D sock_desc 10I 0 value
D translate PR ExtPgm('QDCXLATE')
D length 5P 0 const
D data 32766A options(*varsize)
D table 10A const
D msg S 50A
D sock S 10I 0
D port S 5U 0
D addrlen S 10I 0
D ch S 1A
D host s 32A
D file s 32A
D IP s 10U 0
D p_Connto S *
D RC S 10I 0
D Request S 60A
D ReqLen S 10I 0
D RecBuf S 50A
D RecLen S 10I 0
C*************************************************
C* The user will supply a hostname and file
C* name as parameters to our program...
C*************************************************
c *entry plist
c parm host
c parm file
c eval *inlr = *on
C*************************************************
C* what port is the http service located on?
C*************************************************
c eval p_servent = getservbyname('http':'tcp')
c if p_servent = *NULL
c eval msg = 'Can''t find the http service!'
c dsply msg
c return
c endif
c eval port = s_port
C*************************************************
C* Get the 32-bit network IP address for the host
C* that was supplied by the user:
C*************************************************
c eval IP = inet_addr(%trim(host))
c if IP = INADDR_NONE
c eval p_hostent = gethostbyname(%trim(host))
c if p_hostent = *NULL
c eval msg = 'Unable to find that host!'
c dsply msg
c return
c endif
c eval IP = h_addr
c endif
C*************************************************
C* Create a socket
C*************************************************
c eval sock = socket(AF_INET: SOCK_STREAM:
c IPPROTO_IP)
c if sock < 0
c eval msg = 'Error calling socket()!'
c dsply msg
c return
c endif
C*************************************************
C* Create a socket address structure that
C* describes the host & port we wanted to
C* connect to
C*************************************************
c eval addrlen = %size(sockaddr)
c alloc addrlen p_connto
c eval p_sockaddr = p_connto
c eval sin_family = AF_INET
c eval sin_addr = IP
c eval sin_port = port
c eval sin_zero = *ALLx'00'
C*************************************************
C* Connect to the requested host
C*************************************************
C if connect(sock: p_connto: addrlen) < 0
c eval msg = 'unable to connect to server!'
c dsply msg
c callp close(sock)
c return
c endif
C*************************************************
C* Format a request for the file that we'd like
C* the http server to send us:
C*************************************************
c eval request = 'GET ' + %trim(file) +
c ' HTTP/1.0' + x'0D25' + x'0D25'
c eval reqlen = %len(%trim(request))
c callp Translate(reqlen: request: 'QTCPASC')
C*************************************************
c* Send the request to the http server
C*************************************************
c eval rc = send(sock: %addr(request): reqlen:0)
c if rc < reqlen
c eval Msg = 'Unable to send entire request!'
c dsply msg
c callp close(sock)
c return
c endif
C*************************************************
C* Get back the server's response
C*************************************************
c dou rc < 1
C exsr DsplyLine
c enddo
C*************************************************
C* We're done, so close the socket.
C* do a dsply with input to pause the display
C* and then end the program
C*************************************************
c callp close(sock)
c dsply pause 1
c return
C*===============================================================
C* This subroutine receives one line of text from a server and
C* displays it on the screen using the DSPLY op-code
C*===============================================================
CSR DsplyLine begsr
C*------------------------
C*************************************************
C* Receive one line of text from the HTTP server.
C* note that "lines of text" vary in length,
C* but always end with the ASCII values for CR
C* and LF. CR = x'0D' and LF = x'0A'
C*
C* The easiest way for us to work with this data
C* is to receive it one byte at a time until we
C* get the LF character. Each time we receive
C* a byte, we add it to our receive buffer.
C*************************************************
c eval reclen = 0
c eval recbuf = *blanks
c dou reclen = 50 or ch = x'0A'
c eval rc = recv(sock: %addr(ch): 1: 0)
c if rc < 1
c leave
c endif
c if ch<>x'0D' and ch<>x'0A'
c eval reclen = reclen + 1
c eval %subst(recbuf:reclen:1) = ch
c endif
c enddo
C*************************************************
C* translate the line of text into EBCDIC
C* (to make it readable) and display it
C*************************************************
c if reclen > 0
c callp Translate(reclen: recbuf: 'QTCPEBC')
c endif
c recbuf dsply
C*------------------------
Csr endsr
| |
API - QUSLJOB
Posted By: jimmy octane Contact |
*****************************************************
* List Jobs API (QUSLJOB) prototype
*****************************************************
D QUSLJOB PR ExtPgm('QUSLJOB')
D UserSpace 20A const
D Format 8A const
D QualJob 26A const
D Status 10A const
* optional group 1:
D ErrorCode 8000A options(*varsize: *nopass)
* optional group 2:
D JobType 1A const options(*nopass)
D NbrKeyFld 10I 0 const options(*nopass)
D KeyFlds 10I 0 const dim(1000)
D options(*varsize: *nopass)
* optional group 3:
D ContHandle 48A const options(*nopass)
*****************************************************
* API error code data structure
*****************************************************
D MyErrCode DS
D BytesProv 10I 0 inz(%size(MyErrCode))
D BytesAvail 10I 0 inz(0)
D MsgID 7A
D Reserved 1A
D MessageData 1000A
*****************************************************
* Generic Header Format used by the "List APIs"
*
* There is a lot of information returned in the
* generic header, but all I'm interested in is
* the offsets needed to access the list entries
* themselves.
*****************************************************
D p_ListHeader s *
D ListHeader ds based(p_ListHeader)
D DataOffset 125 128I 0
D NumEntries 133 136I 0
D EntrySize 137 140I 0
*****************************************************
* This structure is designed to match format
* JOBL0100 the QUSLJOB API.
*****************************************************
D p_ListEntry s *
D JOBL0100 ds based(p_ListEntry)
D JobName 10A
D JobUser 10A
D JobNbr 6A
D InternalID 16A
D Status 10A
D JobType 1A
D JobSubtype 1A
*****************************************************
* Create User Space (QUSCRTUS) API
*****************************************************
D QUSCRTUS PR ExtPgm('QUSCRTUS')
D UserSpace 20A const
D Attrib 10A const
D InitSize 10I 0 const
D InitVal 1A const
D PubAuth 10A const
D Text 50A const
* optional group 1:
D Replace 10A const options(*nopass)
D ErrorCode 8000A options(*varsize: *nopass)
* optional group 2:
D Domain 10A const options(*nopass)
* optional group 3:
D XferSizeReq 10I 0 const options(*nopass)
D OptAlign 1A const options(*nopass)
*****************************************************
* Retrieve Pointer to User Space (QUSPTRUS) API
*****************************************************
D QUSPTRUS PR ExtPgm('QUSPTRUS')
D UserSpace 20A const
D Pointer *
D ErrorCode 8000A options(*varsize: *nopass)
D p_Start s *
D Msg s 52A
D EntryNo s 10I 0
**
** Create a user space that the QUSLJOB API can store it's
** output into.
**
** The initial size of the user space will be 256k (256 * 1024)
** however, the QUSLJOB API will extend it if it needs to be
** larger.
**
c callp QUSCRTUS( 'JOBLIST QTEMP'
c : 'MYPGMNAME'
c : 256 * 1024
c : x'00'
c : '*USE'
c : 'List of active jobs'
c : '*YES'
c : MyErrCode )
c if BytesAvail <> 0
c eval Msg = 'QUSCRTUS API failed with ' +
c 'error ' + MsgID
c dsply Msg
c eval *inlr = *on
c return
c endif
**
** List all active jobs on the system. The output
** will go into the user space we created (above)
**
c callp QUSLJOB( 'JOBLIST QTEMP'
c : 'JOBL0100'
c : '*ALL *ALL *ALL'
c : '*ACTIVE'
c : MyErrCode )
c if BytesAvail <> 0
c eval Msg = 'QUSLJOB API failed with ' +
c 'error ' + MsgID
c dsply Msg
c eval *inlr = *on
c return
c endif
**
** Get a pointer to the user space. In this example, the
** "Bytes Provided" field is zero, so the program will halt
** with a "CPFxxxx" error if something goes wrong:
**
c eval BytesProv = 0
c callp QUSPTRUS( 'JOBLIST QTEMP'
c : p_ListHeader )
**
** Use data structure that's based on a pointer to view each
** entry in the list. After viewing each entry, increase
** the pointer so that we view the next item.
**
c eval p_Start = p_ListHeader + DataOffset
c for EntryNo = 1 to NumEntries
c eval p_ListEntry = p_Start +
c (EntryNo - 1) * EntrySize
c eval Msg = %trimr(JobNbr) + '/' +
c %trimr(JobUser) + '/' +
c %trimr(JobName)
c Msg dsply
c
c endfor
**
** That's all, end the program.
**
c eval Msg = 'Press to end program'
c dsply Msg
c eval *inlr = *on
| |
|
|
|
