|
midrange.com
Hi Jared,
maybe this help you. This is a sample ile-cobol that retrieve the ile-c
errno global variable.
Regards, Roy.
PROCESS APOST GENLVL(19) UNREF NOMONOPRC NOSTDTRUNC.
IDENTIFICATION DIVISION.
PROGRAM-ID. Errno.
AUTHOR. Roy.
DATE-WRITTEN. Feb 2003.
* Retrieve C errno global variable after api error
* Send pgm msg with corresponding description
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
DECIMAL-POINT IS COMMA
LINKAGE type PROCEDURE FOR '__errno'
LINKAGE type PROCEDURE FOR 'StrError'.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
* Common Return and Error Codes
01 Errno pic s9(9) binary.
01 StrError pic x(128).
01 pErrno usage pointer.
01 pStrError usage pointer.
01 ErrnoText.
03 pic x(21) value 'EACCES 3401'.
03 pic x(21) value 'ENOTDIR 3403'.
03 pic x(21) value 'ENOSPC 3404'.
03 pic x(21) value 'EXDEV 3405'.
03 pic x(21) value 'EWOULDBLOCK 3406'.
03 pic x(21) value 'EAGAIN 3406'.
03 pic x(21) value 'EINTR 3407'.
03 pic x(21) value 'EFAULT 3408'.
03 pic x(21) value 'ENXIO 3415'.
03 pic x(21) value 'EADDRINUSE 3420'.
03 pic x(21) value 'EADDRNOTAVAIL 3421'.
03 pic x(21) value 'EAFNOSUPPORT 3422'.
03 pic x(21) value 'EALREADY 3423'.
03 pic x(21) value 'ECONNABORTED 3424'.
03 pic x(21) value 'ECONNREFUSED 3425'.
03 pic x(21) value 'ECONNRESET 3426'.
03 pic x(21) value 'EDESTADDRREQ 3427'.
03 pic x(21) value 'EHOSTDOWN 3428'.
03 pic x(21) value 'EHOSTUNREACH 3429'.
03 pic x(21) value 'EINPROGRESS 3430'.
03 pic x(21) value 'EISCONN 3431'.
03 pic x(21) value 'EMSGSIZE 3432'.
03 pic x(21) value 'ENETDOWN 3433'.
03 pic x(21) value 'ENETRESET 3434'.
03 pic x(21) value 'ENETUNREACH 3435'.
03 pic x(21) value 'ENOBUFS 3436'.
03 pic x(21) value 'ENOPROTOOPT 3437'.
03 pic x(21) value 'ENOTCONN 3438'.
03 pic x(21) value 'ENOTSOCK 3439'.
03 pic x(21) value 'ENOTSUP 3440'.
03 pic x(21) value 'EOPNOTSUPP 3440'.
03 pic x(21) value 'EPFNOSUPPORT 3441'.
03 pic x(21) value 'EPROTONOSUPPORT 3442'.
03 pic x(21) value 'EPROTOTYPE 3443'.
03 pic x(21) value 'ERCVDERR 3444'.
03 pic x(21) value 'ESHUTDOWN 3445'.
03 pic x(21) value 'ESOCKTNOSUPPORT 3446'.
03 pic x(21) value 'ETIMEDOUT 3447'.
03 pic x(21) value 'EUNATCH 3448'.
03 pic x(21) value 'EBADF 3450'.
03 pic x(21) value 'EMFILE 3452'.
03 pic x(21) value 'ENFILE 3453'.
03 pic x(21) value 'EPIPE 3455'.
03 pic x(21) value 'EEXIST 3457'.
03 pic x(21) value 'EDEADLK 3459'.
03 pic x(21) value 'ENOMEM 3460'.
03 pic x(21) value 'EOWNERTERM 3462'.
03 pic x(21) value 'EDESTROYED 3463'.
03 pic x(21) value 'ETERM 3464'.
03 pic x(21) value 'EMLINK 3468'.
03 pic x(21) value 'ESPIPE 3469'.
03 pic x(21) value 'ENOSYS 3470'.
03 pic x(21) value 'EISDIR 3471'.
03 pic x(21) value 'EROFS 3472'.
03 pic x(21) value 'EUNKNOWN 3474'.
03 pic x(21) value 'EITERBAD 3475'.
03 pic x(21) value 'EDAMAGE 3484'.
03 pic x(21) value 'ELOOP 3485'.
03 pic x(21) value 'ENAMETOOLONG 3486'.
03 pic x(21) value 'ENOLCK 3487'.
03 pic x(21) value 'ENOTEMPTY 3488'.
03 pic x(21) value 'ENOSYSRSC 3489'.
03 pic x(21) value 'ECONVERT 3490'.
03 pic x(21) value 'E2BIG 3491'.
03 pic x(21) value 'EILSEQ 3492'.
03 pic x(21) value 'ESOFTDAMAGE 3497'.
03 pic x(21) value 'ENOTENROLL 3498'.
03 pic x(21) value 'EOFFLINE 3499'.
03 pic x(21) value 'EROOBJ 3500'.
03 pic x(21) value 'ELOCKED 3506'.
03 pic x(21) value 'EFBIG 3507'.
03 pic x(21) value 'EIDRM 3509'.
03 pic x(21) value 'ENOMSG 3510'.
03 pic x(21) value 'EFILECVT 3511'.
03 pic x(21) value 'EBADFID 3512'.
03 pic x(21) value 'ESTALE 3513'.
03 pic x(21) value 'ESRCH 3515'.
03 pic x(21) value 'ENOTSIGINIT 3516'.
03 pic x(21) value 'ECHILD 3517'.
03 pic x(21) value 'ETOOMANYREFS 3523'.
03 pic x(21) value 'ENOTSAFE 3524'.
03 pic x(21) value 'EOVERFLOW 3525'.
03 pic x(21) value 'EJRNDAMAGE 3526'.
03 pic x(21) value 'EJRNINACTIVE 3527'.
03 pic x(21) value 'EJRNRCVSPC 3528'.
03 pic x(21) value 'EJRNRMT 3529'.
03 pic x(21) value 'ENEWJRNRCV 3530'.
03 pic x(21) value 'ENEWJRN 3531'.
03 pic x(21) value 'EJOURNALED 3532'.
03 pic x(21) value 'EJRNENTTOOLONG 3533'.
03 pic x(21) value 'EDATALINK 3534'.
01 Filler redefines ErrnoText.
03 Filler occurs 91.
05 Errno-Text pic x(17).
05 Errno-Num pic 9(4).
77 iErrno pic s9(5) comp-3.
* Data strucuture for Api QMHSNDPM. this Api sends a
* program message
01 PgmMsg.
02 PgmMsgMsgId.
05 pic x(3).
05 PgmMsgMsgIdNbr pic 9(4).
02 PgmMsgFile pic x(20).
02 PgmMsgData.
05 PgmMsgErrno pic S9(9) binary.
05 PgmMsgStrError pic x(128).
02 PgmMsgLen pic s9(9) binary.
02 PgmMsgType pic x(10) value '*DIAG'.
02 PgmMsgPgmQueue pic x(10) value '*'.
02 PgmMsgPgmStackCnt pic s9(9) binary value 1.
02 PgmMsgKey pic x(4) value spaces.
01 PgmMsgError.
02 PgmMsgErrorProvided pic s9(9) binary value 0.
02 PgmMsgErrorAvailable pic s9(9) binary value 0.
02 PgmMsgRtnMsgid pic x(7) value spaces.
02 PgmMsgReserved pic x(1) value spaces.
02 PgmMsgRtnData pic x(50) value spaces.
LINKAGE SECTION.
01 dErrno pic S9(9) binary.
01 dStrError pic x(128).
PROCEDURE DIVISION.
Main-Client SECTION.
* ------------------------------------------------------------- *
* Standard Error Routines: Retrieve 'C' errno value & send Msg
StdErr.
* 1) __errno returnes the pointer to the error code
CALL PROCEDURE '__errno' GIVING pErrno.
* 2) strerror retieves the pointer to the error description.
* on the AS/400 this is not the text as it can be found in
* QSYSINC/SYS(ERRNO). the string retrieved is NULL terminated
* (X'00') and contains the followiing value:
* 'CPE0001QCPFMSG *LIBL'.
* the digit part of CPE0001 can be replaced by dErrno.
* if for example 3042 is received, the message with message
* id CPE3042 will describe the problem.
CALL PROCEDURE 'strerror' GIVING pStrError.
* 3) set address of linkage section item to have full access
* to data values
set address of dErrno to pErrno.
set address of dStrerror to pStrError.
* 4) Search the Errno Text Descriptive as defined in
* QSYSINC/QSYS(ERRNO). This value is usally
* referred to in the Api documentation
Move spaces to PgmMsgStrError.
Perform varying iErrno from 1 by 1
until iErrno > 91 or dErrno = Errno-Num(iErrno)
String Errno-Num(iErrno) '/'
Errno-Text(iErrno) delimited by size
into PgmMsgStrError
End-Perform.
* 5) Send message CPF9898 with errno text found
Move dErrno to PgmMsgErrno.
Move 'CPF9898' TO PgmMsgMsgId.
Move 'QCPFMSG' TO PgmMsgFile.
Move '*LIBL' TO PgmMsgFile(11:10).
Move Length of PgmMsgData TO PgmMsgLen.
Perform SendMsg.
* 6) Send error message based on dErrno
If dErrno not = zero
Move dStrError(1:7) TO PgmMsgMsgId
Move dErrno TO PgmMsgMsgIdNbr
Move dStrError(8:20) TO PgmMsgFile
Move 0 TO PgmMsgLen
Perform SendMsg.
End-Pgm. Goback.
SendMsg.
CALL 'QMHSNDPM' USING PgmMsgMsgID
PgmMsgFile PgmMsgData
PgmMsgLen PgmMsgType
PgmMsgPgmQueue PgmMsgPgmStackCnt
PgmMsgKey PgmMsgError.
*** End of Source ***
-----Messaggio originale-----
Da: cobol400-l-bounces@xxxxxxxxxxxx [mailto:cobol400-l-bounces@xxxxxxxxxxxx]
Per conto di jared
Inviato: martedì 20 luglio 2004 16.58
A: cobol400 list
Oggetto: [COBOL400-L] [C400-L] ILE return codes (fwd)
figured i should ask this here too...
---------- Forwarded message ----------
Hi All-
I'm calling ILE C procedures, bound into a service program, from inside an
ILE COBOL application. On OS390, I was able to get the return codes from
the C code, as they were showing up in COBOL's return-code special
register. But so far in my V5R2 environment I've yet to get this to work.
The service program is being bound with the default *CALLER activation
group flag. I can step right from the COBOL into the C code, watch the
status variable get set non-zero, step through the return statement, and
verify that return-code still == 0 when I pop back out into the COBOL
side.
Any ideas?
-Jared
_______________________________________________
This is the C programming iSeries / AS400 (C400-L) mailing list
To post a message email: C400-L@xxxxxxxxxxxx
To subscribe, unsubscribe, or change list options,
visit: http://lists.midrange.com/mailman/listinfo/c400-l
or email: C400-L-request@xxxxxxxxxxxx
Before posting, please take a moment to review the archives
at http://archive.midrange.com/c400-l.
_______________________________________________
This is the COBOL Programming on the iSeries/AS400 (COBOL400-L) mailing list
To post a message email: COBOL400-L@xxxxxxxxxxxx
To subscribe, unsubscribe, or change list options,
visit: http://lists.midrange.com/mailman/listinfo/cobol400-l
or email: COBOL400-L-request@xxxxxxxxxxxx
Before posting, please take a moment to review the archives
at http://archive.midrange.com/cobol400-l.
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.
