如何於 AS/400(i5/OS) 上做到 unix 的 spawn job ？
於 AS/400 上要做到 MultiThread 的功能並不容易，因為會有 Resource Lock 的問題，
所以建議以 spawn 方式來達到 MultiThread 的功能，spawn 會將欲執行的子程式 submit
至與執行 spawn API job 相同的子系統下執行。
該 spawned job 為 BCI 形態。
FILE : QRPGLESRC
MEMBER : SPAWNPGMR
Type : RPGLE
Usage : CRTBNDRPG PGM(SPAWNPGMR) SRCFILE(lib/QRPGLESRC) SRCMBR(SPAWNPGMR)
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H BNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*CALLER)
*-- GetErrNo ---- Get error number ----------------------------------
* extern int * __errno(void);
D @__errno PR * ExtProc('__errno')
*-- StrError ---- Get error text ------------------------------------
* char *strerror(int errnum);
D strerror PR * ExtProc('strerror')
D errnum 10I 0 value
D perror PR ExtProc('perror')
D comment * value options(*string)
D errno PR 10I 0
D die PR
D peMsg 256A const
D outMsgType 10A const
* ---------------------------------------------------------------
* spawn() Constants
* ---------------------------------------------------------------
*
D SPAWN_SETSIGMASK...
D C const(x'00000002')
D SPAWN_SETSIGDEF...
D C const(x'00000004')
D SPAWN_SETPGROUP...
D C const(x'00000008')
D SPAWN_SETTHREAD_NP...
D C const(x'00000010')
D SPAWN_SETPJ_NP...
D C const(x'00000020')
D SPAWN_SETCOMPMSG_NP...
D C const(x'00000040')
D SPAWN_FDCLOSED...
D C const(-1)
D SPAWN_NEWPGROUP...
D C const(-1)
D SPAWN_MAX_NUM_ARGS...
D C const(255)
* Spawn API used parameter --------------------------------------
D int_t S 10I 0
D pid_t S like(int_t)
D pid S like(int_t)
D rtnInt S like(int_t)
D path S 128A inz
D Inheritance DS
D flags 10U 0 Inz(0)
D pgroup 10I 0 Inz(0)
D sigmask like(sigset_t)
D sigdefault like(sigset_t)
*
D sigset_t DS
D sig_mask like(sigmask_t)
*
D sigmask_t DS
D lomask 10U 0
D himask 10U 0
D fildes S like(int_t) inz dim(2)
D fildesMap S like(int_t) inz dim(2)
D SpawnArg S * dim(5)
D SpawnEnv S * dim(4)
*-- spawn()--Spawn Process --------------------------------------
D spawn...
D PR extproc('Qp0zSpawn')
D like(pid_t)
D i_path * value options(*string)
D i_fd_count 10I 0 value
D i_fd_map * value
D i_inheritance * value
D i_argv * value
D i_envp * value
D peError S 256A
* rpg parameter
D*rpg_argv1 S 10A inz('argument_1')
D*rpg_argv2 S 20A inz('argument_2---------X')
D*rpg_argv3 S 30A inz('argument_3-------------------X')
* environment
D*envp1 S 64A inz('ENVVAR1=envValue_1')
D*envp2 S 64A inz('ENVVAR2=envValue_2')
D*envp3 S 64A inz('ENVVAR3=envValue_3')
**-- Global variables: ------------------------------------------
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 OBJD0100: ---------------------
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 )
**- Qp0wGetJobID() returns the qualified job name and internal job id
D getJobId PR extproc('Qp0wGetJobID')
D like(int_t)
D child_pid 10i 0 value
D jobinfo like(JobInfoDs)
D JobInfoDs Ds
D JobName 10
D JobUserName 10
D JobNumber 6
D JobId 16
**----------------------------------------------------------------
D QualPgmName Ds
D PgmName 10
D Lib 10
C
C *entry PList
C Parm QualPgmName
C
C ExSr ObjExist
C Clear inheritance
* Start the child process in its own process group. */
C Eval pgroup = SPAWN_NEWPGROUP
* allow the child to create native threads */
C Eval flags = SPAWN_SETTHREAD_NP
C Eval sigmask = *LOVAL
C Eval sigdefault = *LOVAL
C EVAL fildesMap(1)= 0
*****************************************************************
* Set arguments
* Argv(1) must be set as a dummy. This is because of how C pass
* arguments to procedures. Argv(1) is not passed to the spawned
* RPG program.
C EVAL SpawnArg(1)= %addr(path)
* Now let's set the other arguments
C* Eval SpawnArg(2) = %addr(rpg_argv1)
C* Eval SpawnArg(3) = %addr(rpg_argv2)
C* Eval SpawnArg(4) = %addr(rpg_argv3)
* Finally with have to set the "end-of-argument-list" indicat
C* Eval SpawnArg(5) = *NULL
C EVAL SpawnArg(2)= *null
? * Set environment variables
C* Eval envp1 = %trim(envp1) + x'00'
C* Eval envp2 = %trim(envp2) + x'00'
C* Eval envp3 = %trim(envp3) + x'00'
? *
C* Eval SpawnEnv(1) = %addr(envp1)
C* Eval SpawnEnv(2) = %addr(envp2)
C* Eval SpawnEnv(3) = %addr(envp3)
? * Finally with have to set the "end-of-environemt-list" indic
C* Eval SpawnEnv(4) = *NULL
C EVAL SpawnEnv(1)= *Null
C
? * Set program path
C Eval path = '/QSYS.LIB/' +
C %trim(Lib) + '.LIB/' +
C %trim(PgmName) +
C '.PGM'
C EVAL pid= spawn(
C %trim(path):
C 0 :
C %addr(fildesMap):
C %addr(inheritance):
C %addr(SpawnArg):
C %addr(SpawnEnv)
C )
C* dump
C If pid < 0
c eval peError = %str(strerror(errno))
c callp die(peError : '*ESCAPE')
C EndIf
C eval rtnInt = getJobId(
C pid :
C JobInfoDs
C )
**-- Program spawn msg...
C If rtnInt = 0
C eval peError = 'SPAWNPGM: ' +
C %trim(Lib) +
C '/' +
C %trim(PgmName) +
C ' started as ' +
C %trim(jobNumber) + '/' +
C %trim(jobUserName) + '/' +
C %trim(jobName) + ',' +
C ' pid ' +
C %trim(%EditC(pid : 'Z'))
c callp die(peError : '*COMP')
C EndIf
C* dump
C Eval *InLr = *On
*----------------------------------------------------------------
*-- Check Object Exist ? ---------------------------------------
*----------------------------------------------------------------
C ObjExist BegSr
C Eval ObjNam = PgmName
C Eval ObjLib = Lib
C Eval ObjTyp = '*PGM'
**
C CallP RtvObjD( RoData
C : %Size( RoData )
C : 'OBJD0100'
C : ObjNam + ObjLib
C : ObjTyp
C : ApiError
C )
**
C If AeBytAvl > *Zero
C select
C when AeMsgId = 'CPF9801'
**-- Object doesn't exist...
C eval peError = 'Object ' +
C %trim(PgmName) +
C ' in ' +
C %trim(Lib) +
C ' not found.'
C when AeMsgId = 'CPF9810'
**-- Library doesn't exist...
C eval peError = 'Library ' +
C %trim(Lib) +
C ' not found.'
C when AeMsgId = 'CPF9811'
**-- Program doesn't exist...
C eval peError = 'Program ' +
C %trim(PgmName) +
C ' in ' +
C %trim(Lib) +
C ' not found.'
C other
C eval PeError = 'Error MSGID: ' + AeMsgId
C EndSl
C callp die(peError : '*ESCAPE')
C Else
C eval Lib = RoObjLibRt
C EndIf
C EndSr
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This ends this program abnormally, and sends back an escape.
* message explaining the failure.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P die B
D die PI
D peMsg 256A const
D outMsgType 10A const
D SndPgmMsg PR ExtPgm('QMHSNDPM')
D MessageID 7A Const
D QualMsgF 20A Const
D MsgData 256A Const
D MsgDtaLen 10I 0 Const
D MsgType 10A Const
D CallStkEnt 10A Const
D CallStkCnt 10I 0 Const
D MessageKey 4A
D ErrorCode 32766A options(*varsize)
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 wwMsgLen S 10I 0
D wwTheKey S 4A
c eval wwMsgLen = %len(%trimr(peMsg))
c if wwMsgLen<1
c return
c endif
c select
c when outMsgType = '*COMP'
c callp SndPgmMsg('CPF9897': 'QCPFMSG *LIBL':
c peMsg: wwMsgLen: '*COMP':
c '*PGMBDY': 1: wwTheKey: dsEC)
c other
c callp SndPgmMsg('CPF9897': 'QCPFMSG *LIBL':
c peMsg: wwMsgLen: '*ESCAPE':
c '*PGMBDY': 1: wwTheKey: dsEC)
c endSl
c return
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This procedure return call socket C API errno
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P errno B
D errno PI 10I 0
D p_errno S *
D wwreturn S 10I 0 based(p_errno)
C eval p_errno = @__errno
c return wwreturn
P E
FILE : QCMDSRC
MEMBER : SPAWNPGM
Type : CMD
Usage : CRTCMD CMD(SPAWNPGM) PGM(SPAWNPGMR) SRCFILE(lib/QCMDSRC) SRCMBR(SPAWNPGM)
/********************************************************************/
/* */
/* File: QCMDSRC */
/* Member: SPAWNPGM */
/* Type: CMD */
/* Desc: Command source for the SPAWNPGM Command */
/* */
/********************************************************************/
CMD PROMPT('Spawn Program')
/****************************************/
/*** parameters ***/
/****************************************/
PARM KWD(PGM) TYPE(Q1) MIN(1) MAX(1) PROMPT('Program')
/****************************************/
/*** type qualifiers ***/
/****************************************/
Q1: QUAL TYPE(*NAME) LEN(10)
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
SPCVAL((*LIBL)) PROMPT('Library')
星期一, 11月 06, 2023
2004-06-14 如何於 AS/400(i5/OS) 上做到 unix 的 spawn job ？(Command SPAWNPGM)
訂閱：
張貼留言 (Atom)
沒有留言:
張貼留言