Debug 132x27 mode
Normally STRDBG starts in 80x24 mode. You can change this mode to 132x27 mode with the
following environment variable:
AddEnvVar EnvVar('ILE_DEBUGGER_1') +
Value('ALLOW_WIDE_SCREEN') +
Level(*Job) Replace(*Yes)
To go back to 80x24 mode, you use:
RmvEnvVar EnvVar('ILE_DEBUGGER_1') Level(*Job)
Create two CLLE-programs, eg. DBGWIDE and ENDWIDE. Add an extra statement
MonMsg CPFA981
to the ENDWIDE - to prevent at dump, if DBGWIDE has not been initiated.
Wrap these two CLLE's into two commands with the same names, place them in QGPL
and your *On/*Off the two debug-modes.
The information originated from Karl Hanson of IBM, Rochester who works/worked on the
debuggers for IBM.
DLYJOB inside RPG IV
To delay an internal loop inside a RPG program, or to delay a call to another program, use 'sleep' or 'usleep'
H BndDir('QC2LE')
D Sleep Pr 10I 0 ExtProc('sleep')
D Seconds 10U 0 Value
D Usleep Pr 10I 0 ExtProc('usleep')
D Microsecs 10U 0 Value
* Sleep for 30 seconds
C CallP Sleep(0030)
* Sleep for 30 seconds
C CallP Usleep(0030000000)
Note from Chris:
It's working now. Thanks. My testing shows that 1000000 is valid for usleep (it does
the delay). And values over 1000000 don't delay and the return value is zero, not -1.
Note from Mel:
My testing showed the same results as yours.
That is, for values <= 1,000,000, usleep sleeps that many microseconds and returns 0.
For values > 1,000,000, it sleeps 0 microseconds and returns 0. Although the documentation says
it should return -1 and set errno to indicate why it failed, in my testing, both the return value
and the errno were always 0.
Also, the documentation says the return value is an unsigned integer, which would be impossible
for it to return -1. The prototype in QSYSINC/H member UNISTD, defines the return code as int,
which is signed.
Finally, the documentation says the "usleep() function is included for its historical usage.
The setitimer() function is preferred over this function."
So, it appears that both the code and documentation contain errors and we should look at
setitimer() instead.
CmdLine Program Call with 2 num. parameters
From a commandlinie a program can be called, as here with 2 num. parameters with the
values of -421 og 98200:
Call Pgm(LIBRARY/PROGRAM) Parm(X'421D' X'98200F') Packed
Call Pgm(LIBRARY/PROGRAM) Parm(X'F4F2D1' X'F9F8F2F0F0') Zoned
Search for filename in path
But, here's a slightly more efficient method. Rather than scanning the
string several times to find all the slashes, it uses the C "strrchr"
function which scans for a single character, starting at the end of
the string... since it only scans the string once, it'll run slightly
faster...
H DFTACTGRP(*NO) ACTGRP(*NEW) BNDDIR('QC2LE')
D basename PR 256A
D path 256A const
D my_file S 50A
D my_path S 256A
c eval my_path = '/NPR-SERVER-NT/SCANNING/' +
c 'Common/Steve%20Maher/' +
c 'EAR90881/AC9012F1240Y6.B.HPGL'
c eval my_file = basename(my_path)
c dsply my_file
c eval *inlr = *on
P basename B
D basename PI 256A
D path 256A const
d strrchr PR * extproc('strrchr')
d wholestr * value options(*string)
d char 10I 0 value
D SLASH c const(97)
D p S *
c eval p = strrchr(path: SLASH)
c if p = *NULL
c return *blanks
c else
c eval p = p + 1
c return %str(p)
c endif
P E
Convert Decimal to Fractional Notation
Bob O. wrote:
Does anyone have an example of converting a decimal number to it's fractional equivalent?
For example: 15.3750 = 15-3/8
The decimal field to convert is a 10/4 field. Any help is appreciated.
Hans replied:
Hmmm, I was thinking of whipping up a procedure, so I typed "strseu qrpglesrc
fract", and up popped a program already written! So, here it is. No promises though
on completeness or correctness in all cases. And you'd probably want to add a parameter
to specify some maximum for the denominator. And you'd probably want to change to 10I0
variables to 20I0 (and atoi() to atoll()). But it should get you going.
BTW, this particular program outputs:
> call fract
DSPLY 123 57/125
DSPLY 123
DSPLY 123 17/50
DSPLY 123 1929/15625
DSPLY 123 4/5
DSPLY 123 1/8
H dftactgrp(*no) bnddir('QC2LE')
D fraction pr 50a varying
D numstr 50a varying value
/free
dsply (fraction('123.4560'));
dsply (fraction('123.0000'));
dsply (fraction('123.34'));
dsply (fraction('123.123456'));
dsply (fraction('123.8'));
dsply (fraction('123.125'));
*inlr = *on;
/end-free
//--------------------------------------------------------------
// Procedure: fraction
//--------------------------------------------------------------
// Convert number string from decimal to fractional form.
//
// Parameters:
// I: numstr -- string representing decimal numeric value
//
// Returns:
// String of number in reduced fractional form.
//--------------------------------------------------------------
P fraction b
D fraction pi 50a varying
D numstr 50a varying value
D atoi pr 10i 0 extproc('atoi')
D str * value options(*string)
D int s 10i 0
D dec s 10i 0 inz(0)
D decpos s 10i 0
D numerator s 10i 0
D denominator s 10i 0
D factor s 10i 0
/free
// slough trailing blanks and zeros in number string
dow %subst(numstr:%len(numstr):1) = ' '
or %subst(numstr:%len(numstr):1) = '0';
%len(numstr) = %len(numstr) - 1;
enddo;
// find decimal point
decpos = %scan('.':numstr);
// return now if we don't have decimal digits
if decpos = 0;
return numstr;
elseif decpos = %len(numstr);
return %subst(numstr:1:decpos-1);
endif;
// find digits to the left and right of the decimal point
int = atoi (%subst(numstr:1:decpos-1));
dec = atoi (%subst(numstr:decpos+1));
// determine numerator and denominator
numerator = dec;
denominator = %inth(10**(%len(numstr)-decpos));
// reduce fraction to smallest possible numerator/denominator
for factor = 2 to %div(denominator:2);
dow %rem(numerator:factor) = 0
and %rem(denominator:factor) = 0;
numerator = %div(numerator:factor);
denominator = %div(denominator:factor);
enddo;
endfor;
// return fractional string
return %char(int) + ' ' + %char(numerator)
+ '/' + %char(denominator);
/end-free
P fraction e
Restart NetServer
Q:
We just had our Netserver stop and now it won't start, gets error code 5 -
Start of the NetBIOS over TCP/IP failed with return code 3418.
A:
Call Pgm(QZLSSTRS) Parm('1' X'00000000')
The '1' tells it to reset. Passing a '0' in that first parm is how you
would normally restart it through the api.
Check jobs for Temporary storage over 50Mb
This is the CHKTMPSTG routine I mentioned. Just compile & call it.
Change the size threshold (scan on L_KeyValue) from 50Mb to whatever value seems useful.
********************************************************************
* CHKTMPSTG: Check jobs for Temporary storage over 50Mb
********************************************************************
********************************************************************
* Data Structures
********************************************************************
* Standard error code DS for API error handling
D Error_Code DS
D BytesProvd 10I 0 INZ(0)
D BytesAvail 10I 0 INZ(0)
D Except_ID 7
D Reserved 1
D Exception 256
* Receiver value DS for user space header info
* (used in first call to QUSRTVUS)
D GenRcvrDS DS
D UserArea 64
D GenHdrSize 10I 0
D StrucLevel 4
D FormatName 8
D APIUsed 10
D CreateStamp 13
D InfoStatus 1
D SizeUsUsed 10I 0
D InpParmOff 10I 0
D InpParmSiz 10I 0
D HeadOffset 10I 0
D HeaderSize 10I 0
D ListOffset 10I 0
D ListSize 10I 0
D ListNumber 10I 0
D EntrySize 10I 0
********************************************************************
* Type Definition for the JOBL0100 format.
********************************************************************
D ListDataDS DS
D L_JobName 10
D L_JobUser 10
D L_JobNbr 6
D L_JobIdent 16
D L_Status 10
D L_JobType 1
D L_JobSubTy 1
D L_Reserved 2
D L_JobInfoSts 1
D L_Reserved2 3
D L_NbrFldsRtn 10I 0
D L_LenInfoRtn 10I 0
D L_KeyFld 10I 0
D L_DataType 1
D L_Reserved3 3
D L_LenDataRtn 10I 0
D L_KeyValue 10I 0
********************************************************************
* Field definitions
********************************************************************
D DataLength S 10I 0 INZ(140)
D CurrentEnt S 5P 0 INZ(1)
D ExtendAttr S 10 INZ('USRSPC ')
D InitialSiz S 10I 0 INZ(1024)
D InitialVal S 1 INZ(X'00')
D JobStatus S 10 INZ('*ACTIVE ')
D JobType S 1 INZ('*')
D ListFormat S 8 INZ('JOBL0200')
D NbrToRtn S 10I 0 INZ(1)
D KeysToRtn S 10I 0 INZ(2009)
D P_DataLength S 10I 0
D P_MsgData S 512
D P_MsgFile S 20 INZ('QCPFMSG *LIBL')
D P_MsgID S 7 INZ('CPDA0FF')
D P_MsgKey S 4
D P_MsgType S 10
D P_PgmQueue S 10
D P_PgmStack S 10I 0
D PublicAut S 10 INZ('*ALL ')
D QualifyJob S 26 INZ('*ALL *ALL *ALL ')
D ReplaceSpc S 10 INZ('*YES ')
D StartPos S 10I 0 INZ(1)
D TextDescrp S 50 INZ('User space for List Job API')
D UserSpace S 20 INZ('CHKTMPSTG QTEMP ')
********************************************************************
* MAINLINE:
********************************************************************
* Create a user space to hold the job list entries
C CALL 'QUSCRTUS'
C PARM UserSpace
C PARM ExtendAttr
C PARM InitialSiz
C PARM InitialVal
C PARM PublicAut
C PARM TextDescrp
C PARM ReplaceSpc
C PARM Error_Code
* List all the jobs on the system
C CALL 'QUSLJOB'
C PARM UserSpace
C PARM ListFormat
C PARM QualifyJob
C PARM JobStatus
C PARM Error_Code
C PARM JobType
C PARM NbrToRtn
C PARM KeysToRtn
* Get the header info for this space
C CALL 'QUSRTVUS'
C PARM UserSpace
C PARM StartPos
C PARM DataLength
C PARM GenRcvrDS
C PARM Error_Code
* Check to see if any entries returned
B001 C IF ListNumber > 0
* Set the initial offset for the start of the list entries
C EVAL ListOffset = ListOffset + 1
* Loop through the entries held in the list section of the user space
B002 C DOW CurrentEnt <= ListNumber
* Get the header info for this space
C CALL 'QUSRTVUS'
C PARM UserSpace
C PARM ListOffset
C PARM EntrySize
C PARM ListDataDS
C PARM Error_Code
*
B003 C IF L_KeyValue > 50
C EVAL P_MsgData = 'Job ' + L_JobNbr + '/' +
C %TRIM(L_JobUser) + '/' + %TRIM(L_JobName) +
C ' is using temp storage of ' +
C %EDITC(L_KeyValue : 'Z') + 'Mb'
C
C EVAL P_DataLength = 78
C EVAL P_PgmStack = 0
C EVAL P_PgmQueue = '*EXT'
C EVAL P_MsgType = '*INFO'
*
C CALL (E) 'QMHSNDPM'
C PARM P_MsgID
C PARM P_MsgFile
C PARM P_MsgData
C PARM P_DataLength
C PARM P_MsgType
C PARM P_PgmQueue
C PARM P_PgmStack
C PARM P_MsgKey
C PARM Error_Code
E003 C ENDIF
* Bump up the counter & offset for the next entry
C EVAL ListOffset = ListOffset + EntrySize
C EVAL CurrentEnt = CurrentEnt + 1
E002 C ENDDO
E001 C ENDIF
*
C EVAL *INLR = *ON
C RETURN
Retrieve System Processor & Interactive Features
The following RPGLE program gets and formats a message like:
"Type 9406 Model 720 Prc Grp P10 fc 206A Serial 10-2844M 1024mb Rel V5R1M0."
H BndDir('QC2LE') DftActGrp(*NO) ActGrp(*CALLER)
H Debug Option(*srcstmt : *nodebugio)
D sndMsg PR
D msgText 80 Const
D matmatr PR ExtProc('matmatr')
D attributes * Value
D attrLen 5i 0 Value
D machineAttributes...
D DS inz
D MMTR_Template_Size...
D 10i 0
D MMTR_Bytes_Used...
D 10i 0
D MMTR_VPD 4096
D VPDOffsets DS inz
D vRes1 8
D vMemOff 10i 0
D vPrcOff 10i 0
D vColOff 10i 0
D vCecOff 10i 0
D vPnlOff 10i 0
D vRes2 12
D vMemInstalled 5i 0
D vMemRequired 5i 0
D cecVPD DS inz
D cCEC_read 4
D cManufacturin 4
D creserved1 4
D cType 4
D cModel 4
D cPseudo_Model 4
D cGroup_Id 4
D creserved2 4
D cSys_Type_Ext 1
D cFeature_Code 4
D cSerial_No 10
D creserved3 1
D panelVPD DS inz
D preserved1 2
D pPanel_Type 4
D pModel 3
D pPart 12
D preserved2 4
D pManufacturin 4
D pROS_Part 12
D pROS_Card 10
D pROS_ID 1
D pROS_Flag 1
D pROS_Fix 1
D pSerial_No 10
D $MMTR_SERIAL_ S 5I 0 inz(4)
D $MMTR_VPD_ S 5i 0 inz(x'012c')
D prErrStruc DS inz
D prErrSSize 10i 0 inz(%len(prErrStruc))
D PrErrSUse 10i 0
D prErrSmsgID 7
D prErrSResrv 1
D prErrSData 80
D prRcvr s 128
D prRcvrLen s 10i 0 inz(%size(prRcvr))
D prFormat s 8 inz('PRDR0100')
D prPrdInfo s 27 inz('*OPSYS *CUR 0000*CODE ')
D prErr s Like(prErrStruc)
D prRelease s 6
C Eval MMTR_Template_Size =
%size(machineAttributes)
C CallP matmatr( %ADDR(machineAttributes) :
C $MMTR_VPD_ )
C Eval VPDOffsets = %subst(MMTR_VPD:
C 1:
C %len(VPDOffsets))
C Eval cecVPD = %subst(MMTR_VPD:
C vCecOff-7:
C %len(cecVPD))
C Eval panelVPD = %subst(MMTR_VPD:
C vPnlOff-7:
C %len(panelVPD))
C Eval prErr = prErrStruc
C Call 'QSZRTVPR'
C Parm prRcvr
C Parm prRcvrLen
C Parm prFormat
C Parm prPrdInfo
C Parm prErr
C Eval prErrStruc = prErr
C Eval prRelease = %subst(prRcvr: 20: 6)
C CallP sndMsg('Type ' + %trim(cType) +
C ' Model ' + %trim(cModel) +
C ' Prc Grp ' + %trim(cGroup_ID) +
C ' fc ' + %trim(cFeature_Code) +
C ' Serial ' + %trim(cSerial_No) +
C ' ' +
%trim(%editc(vMemInstalled:'Z')) +
C 'mb Rel ' + %trim(prRelease) )
C Eval *inLR = *On
C Return
PsndMsg B
DsndMsg PI
D inpText 80 Const
* Send message API parameters
D msgID s 7 inz('CPF9898')
D msgFil s 20 inz('QCPFMSG *LIBL ')
D msgData s Like(inpText)
D msgDataLen s 10i 0 inz(%size(msgData))
D msgType s 10 inz('*INFO')
D msgStackEnt s 10 inz('*')
D msgStackCnt s 10i 0 inz(3)
D msgKey s 4
D msgErrStruc s Like(ErrStruc)
* API error structure
D errStruc DS inz
D errSSize 10i 0 inz(%len(errStruc))
D errSUse 10i 0
D errSmsgID 7
D errSResrv 1
D errSData 80
C Eval msgData = inpText
C Eval msgErrStruc = errStruc
C Call 'QMHSNDPM'
C Parm msgID
C Parm msgFil
C Parm msgData
C Parm msgDataLen
C Parm msgType
C Parm msgStackEnt
C Parm msgStackCnt
C Parm msgKey
C Parm msgErrStruc
C Eval errStruc = msgErrStruc
PsndMsg E
National Language Version & QCCSID
This is out of my "Everything You Always Wanted to know about System Values
(but were afraid to ask)" pitch from COMMON.
|-----------------------------+------+--------|
| National Language Version | NLV | QCCSID |
|-----------------------------+------+--------|
| Afrikaans (South Africa) | n/a | 00037 |
|-----------------------------+------+--------|
| Albanian (Albania) | 2995 | 00500 |
|-----------------------------+------+--------|
| Arabic | 2954 | 00420 |
|-----------------------------+------+--------|
| Australian English | | |
| (Australia) | n/a | 00037 |
|-----------------------------+------+--------|
| Belgian Dutch MNCS | 2963 | 00500 |
|-----------------------------+------+--------|
| Belgian English | 2909 | 00500 |
|-----------------------------+------+--------|
| Belgian French MNCS | 2966 | 00500 |
|-----------------------------+------+--------|
| Brazilian Portuguese | 2980 | 00037 |
|-----------------------------+------+--------|
| Bulgarian (Bulgaria) | 2974 | 01025 |
|-----------------------------+------+--------|
| Byelorussia (Belarus) | n/a | 01025 |
|-----------------------------+------+--------|
| Canadian French MNCS | 2981 | 00500 |
|-----------------------------+------+--------|
| Croatian | 2912 | 00870 |
|-----------------------------+------+--------|
| Czech | 2975 | 00870 |
|-----------------------------+------+--------|
| Danish | 2926 | 00277 |
|-----------------------------+------+--------|
| Dutch Netherlands | 2923 | 00037 |
|-----------------------------+------+--------|
| English Uppercase | 2950 | 00037 |
|-----------------------------+------+--------|
| English Uppercase and | | |
| Lowercase | 2924 | 00037 |
|-----------------------------+------+--------|
| English Uppercase DBCS | 2938 | 65535 |
|-----------------------------+------+--------|
| English Uppercase and | | |
| Lowercase DBCS | 2984 | 65535 |
|-----------------------------+------+--------|
| Estonian | 2902 | 01122 |
|-----------------------------+------+--------|
| Farsi | 2998 | 01097 |
|-----------------------------+------+--------|
| Finnish | 2925 | 00278 |
|-----------------------------+------+--------|
| French | 2928 | 00297 |
|-----------------------------+------+--------|
| French MNCS | 2940 | 00500 |
|-----------------------------+------+--------|
| German | 2929 | 00273 |
|-----------------------------+------+--------|
| German MNCS | 2939 | 00500 |
|-----------------------------+------+--------|
| Greek | 2957 | 00875 |
|-----------------------------+------+--------|
| Hebrew | 2961 | 00424 |
|-----------------------------+------+--------|
| Hungarian | 2976 | 00870 |
|-----------------------------+------+--------|
| Icelandic | 2958 | 00871 |
|-----------------------------+------+--------|
| Irish Gaelic (Ireland) | n/a | 00285 |
|-----------------------------+------+--------|
| Italian | 2932 | 00280 |
|-----------------------------+------+--------|
| Italian MNCS | 2942 | 00500 |
|-----------------------------+------+--------|
| Japanese (Katakana) DBCS | 2962 | 05026 |
|-----------------------------+------+--------|
| Korean DBCS | 2986 | 00933 |
|-----------------------------+------+--------|
| Laotian | 2906 | 01132 |
|-----------------------------+------+--------|
| Latvian | 2904 | 01122 |
|-----------------------------+------+--------|
| Lithuanian | 2903 | 01122 |
|-----------------------------+------+--------|
| Macedonian | 2913 | 01025 |
|-----------------------------+------+--------|
| Norwegian | 2933 | 00277 |
|-----------------------------+------+--------|
| Polish | 2978 | 00870 |
|-----------------------------+------+--------|
| Portuguese | 2922 | 00037 |
|-----------------------------+------+--------|
| Portuguese MNCS | 2996 | 00500 |
|-----------------------------+------+--------|
| Romanian (Romania) | 2992 | 00870 |
|-----------------------------+------+--------|
| Russian | 2979 | 01025 |
|-----------------------------+------+--------|
| Serbian Cyrillic (Serbia) | 2914 | 01025 |
|-----------------------------+------+--------|
| Serbian Latin (Serbia) | n/a | 00870 |
|-----------------------------+------+--------|
| Simplified Chinese DBCS | | |
| (PRC) | 2989 | 00935 |
|-----------------------------+------+--------|
| Slovakian | 2994 | 00870 |
|-----------------------------+------+--------|
| Slovenian | 2911 | 00870 |
|-----------------------------+------+--------|
| Spanish | 2931 | 00284 |
|-----------------------------+------+--------|
| Swedish | 2937 | 00278 |
|-----------------------------+------+--------|
| Thai | 2972 | 09030 |
|-----------------------------+------+--------|
| Traditional Chinese DBCS | | |
| (ROC) | 2987 | 00937 |
|-----------------------------+------+--------|
| Turkish | 2956 | 01026 |
|-----------------------------+------+--------|
| UK English (United Kingdom) | n/a | 00285 |
|-----------------------------+------+--------|
| Vietnamese | 2905 | 01130 |
|-----------------------------+------+--------|
Encoding routine for creating XML documents
Just encode the string by checking each byte. If the byte is a special
character, replace it. Here is the encode routine I use for creating XML
documents, you should be able to use it with just a few changes:
*****************************************************************
* XML encode special characters
*****************************************************************
P xml_encode b export
D xml_encode pi 512 Varying
D buffer 512 Varying Const
D encoded S 512 Varying
D max S 10u 0
D i S 10u 0
D byte S 1
* encode bytes
C eval max = %len(buffer)
C 1 do max i
C eval byte = %subst(buffer:i:1)
C select
C byte wheneq '&'
C eval encoded = encoded + '&'
C byte wheneq ''''
C eval encoded = encoded + '''
C byte wheneq '"'
C eval encoded = encoded + '"'
C byte wheneq '<'
C eval encoded = encoded + '<'
C byte wheneq '>'
C eval encoded = encoded + '>'
C other
C eval encoded = encoded + byte
C endsl
C enddo
C return encoded
P xml_encode e
Monitor for a disabled userprofile
PGM
DCL VAR(&CLOCKSTS) TYPE(*CHAR) LEN(10)
TOP:
RTVUSRPRF USRPRF(user) STATUS(&CLOCKSTS)
/* retrieve 'user' profile */
/* Do Loop */
IF COND(&CLOCKSTS = '*DISABLED') THEN(DO)
/* check 'user' profile status */
CHGUSRPRF USRPRF(CLOCK) STATUS(*ENABLED)
/* Change to enabled */
CHGVAR VAR(&CLOCKSTS) VALUE(' ')
/* reset variable - &clocksts */
ENDDO
/* End Do Loop */
DLYJOB DLY(300)
/* wait 5 minutes */
GOTO CMDLBL(TOP)
/* recheck clock status */
ENDPGM
