0010 FQPRINT O F 132 Printer OFLind(*INOF) 0020 D/COPY qcpysrc,datatype 0030 D/COPY qcpysrc,opdesc 0040 D PSDS SDS 0050 D Parms *PARMS 0060 D nCount S Like(int4) 0070 D szOutput S 50A 0080 D/COPY qcpysrc,time ** Note: On some AS/400s, LIKE(ds) does not compile ** There is a PTF available. If you need to ** compile, simply change the return value on ** the next line to a '36A' value. 0090 D DatToTM PR Like(TM) 0100 D dtVal D const DatFmt(*ISO) 0110 D rtn_TM Like(tm) options(*NOPASS) ** Pre-V3R7 routine to retrieve char-value length ** Parm 1 is a character value/const ** RETURN value is the length of the char value ** NOTE: LEN can only be used with CHAR fields, not Numerics. ** This is a quick-n-dirty routine for pre-V3R7 systems. ** If OS/400 V3R7 or later is in use, use %LEN and delete ** these prototypes. 0120 D LEN PR 10i 0 OPDESC 0130 D inString 4096A const options(*varsize) ** Pre-V3R7 c-string to char field routine ** Parm 1 is pointer to null terminated string ** Parm 2 is option, and returns the length of ** the return string. ** RETURN value is a character field up to 4k in length 0140 D str PR 4096A OPDESC 0150 D pString * const 0160 D nStrLen options(*nopass) like(int) 0170 D szTime S 50A 0180 D szcTime S 50A 0190 D pfmtTime S like(ptr) inz(%addr(fmtTime)) 0200 D pfmtStr S like(ptr) inz(%addr(fmtStr)) 0210 D TM2 S Like(TM) 0220 D fmtTime S 50A 0230 D fmtStr S 50A INZ('%%A, %%B %%d, %%Y = + 0240 D %A, %B %d, %Y') 0250 D nDST S Like(int) 0260 D PrtTime PR 0270 D szFmt 50A const ***************************************************************** ** NOTE: This source is written for V3 R2 and later. ** Since V3R2 does not support %LEN and %STR built-in ** functions, RPG IV subprocedures have been written ** that perform the identical function. They are named ** LEN and STR respectively. ** --------------------------------------------------------- ** ** If you are running V3R7 or later, do a Find/Replace ** of this source as follows: ** Find -> LEN( Replace with -> %LEN( ** Find -> STR( Replace with -> %STR( ** Occurrences to process: 2 ** Allow data shift: Y ** --------------------------------------------------------- ** ***************************************************************** ***************************************************************** ** Get the current time into the "time_t" structure (long int) ***************************************************************** 0280 C CallP time( Time_t ) 0290 C Eval szCTime = str(ctime( Time_t )) 0300 C Eval %Subst(szCTime:Len(%TrimR(szCTime)):1)= ' ' 0310 C Eval pTM = localtime( Time_t ) 0320 C Eval szTime = str( asctime( TM ) ) 0330 C Eval %Subst(szTime : Len(%TrimR(szTime)):1)= ' ' 0340 C Eval nCount = %size(fmtTime) 0350 C CallP strFTime(pfmtTime : nCount : 0360 C fmtStr : TM) 0370 C Eval szTime = 'asctime ' + %TrimR(szTime) 0380 C Eval szCTime = 'ctime ' + %trimR(szCTime) 0390 C Eval fmtTime = 'strFtime ' + %trimr(fmtTime) 0400 C Eval szOutput = szTime 0410 C Except Output 0420 C Eval szOutput = szCTime 0430 C Except Output 0440 C Eval szOutput = fmtTime 0450 C Except Output 0460 C CallP PrtTime('a = %a') 0470 C CallP PrtTime('A = %A') 0480 C CallP PrtTime('b = %b') 0490 C CallP PrtTime('B = %B') 0500 C CallP PrtTime('c = %c') 0510 C CallP PrtTime('d = %d Day of month ') 0520 C CallP PrtTime('e = %e unknown ') 0530 C CallP PrtTime('H = %H Hour (24 hour clock)') 0540 C CallP PrtTime('I = %I Hour (12 hour clock)') 0550 C CallP PrtTime('j = %j Julian day ') 0560 C CallP PrtTime('m = %m Month 01-12 ') 0570 C CallP PrtTime('M = %M Minute 00-59 ') 0580 C CallP PrtTime('p = %p AM/PM notation ') 0590 C CallP PrtTime('S = %S Seconds 00-59 ') 0600 C CallP PrtTime('U = %U Week of year (SUN) ') 0610 C CallP PrtTime('w = %w Weekday (0 to 6) ') 0620 C CallP PrtTime('W = %W Week of year (MON) ') 0630 C CallP PrtTime('x = %x Formatted date ') 0640 C CallP PrtTime('X = %X Formatted time ') 0650 C CallP PrtTime('y = %y 2-digit year ') 0660 C CallP PrtTime('Y = %Y 4-digit year ') 0670 C CallP DatToTM(D'1958-07-23' : TM2) 0680 C CallP strFTime(pfmtTime : nCount : 0690 C fmtStr : TM2) ***************************************************************** **-------------------------------------------------------------** **++ END PROGRAM **-------------------------------------------------------------** ***************************************************************** ** End the RPG program 0700 C EVAL *INLR = *ON ** End the Activation Group 0710 C CALLB(D) 'CEETREC' ** Return to the caller 0720 C RETURN ***************************************************************** **-------------------------------------------------------------** ** O U T P U T S P E C S ** **-------------------------------------------------------------** ***************************************************************** 0730 OQPRINT E Output 1 0740 O szOutput +5 ***************************************************************** **--------------------------------------------------------------- **++ Version 3, Release 2 compatible routines **++ STR returns a CHAR field after scanning a pointer for X'00'. **++ LEN returns the length of the character input parameter. **--------------------------------------------------------------- **++ If at Version 3, Release 7 or later, delete these routines **++ and use %STR and %LEN in their place. ***************************************************************** ***************************************************************** **++ STR returns a character field from a C-style null **++ terminated string. **++ PARM 1 - pointer to a buffer containing a null **++ terminated string. That is an array of **++ characters followed by a X'00'. **++ PARM 2 - OPTION - Returns the length of the returned **++ character value. **++ RETURN - A 4k field value that contains the data **++ from the buffer pointed to by parameter 1, **++ up to but not including, the null. **--------------------------------------------------------------- 0750 P str B EXPORT 0760 D STR PI 4096A OPDESC 0770 D pString * const 0780 D nStrLen options(*nopass) like(int) 0790 D inString S 4096A based(pString) 0800 D inLen S Like(int) 0810 D outString S Like(inString) 0820 D nPos S Like(int) 0830 C dow %Subst(inString : nPos + 1 : 1) <> X'00' 0840 C AND nPos < %size(inString) 0850 C Add 1 nPos 0860 C Eval %Subst(outString: nPos:1) = 0870 C %Subst(inString: nPos:1) 0880 C endDo 0890 C if %Parms >= 2 0900 C Eval nStrLen = nPos 0910 C endIf 0920 C return outString 0930 P STR E ***************************************************************** **++ LEN returns the length of the character input parameter. **++ INPUT - const char field up to 4k in length. **++ RETURN - runtime length of input parameter. **++ Useful when %TRIMR is embedded within it. **--------------------------------------------------------------- 0940 P LEN B EXPORT 0950 D len PI 10i 0 OPDESC 0960 D inString 4096A const options(*varsize) 0970 D nLen S 10I 0 0980 D nInfo s 10I 0 0990 D nType s 10I 0 1000 D nInfo1 s 10I 0 1010 D nInfo2 s 10I 0 1020 C CallP GetOpDesc(1: nInfo:nType:nInfo1:nInfo2: 1030 C nLen: *OMIT) 1040 C return nLen 1050 P LEN E **--------------------------------------------------------------- 1060 P PrtTime B 1070 D PrtTime PI 1080 D szInput 50A const 1090 D pFmt S * Inz(%Addr(szFmt)) 1100 D szFmt S Like(szInput) 1110 D pBuffer S * inz(%Addr(rtnBuffer)) 1120 D rtnBuffer S 100A 1130 C Eval szFmt = szInput 1140 C CallP strFTime(pBuffer : %Len(rtnBuffer)-1 : 1150 C szFmt : TM) 1160 C Eval szOutput = rtnBuffer 1170 C Except Output 1180 P PrtTime E 1190 P DatToTM B Export 1200 D DatToTM PI Like(TM) 1210 D dtVal D const DatFmt(*ISO) 1220 D rtn_TM Like(tm) options(*NOPASS) 1230 D nDay S 10i 0 1240 D nMonth S 10i 0 1250 D nYear S 10i 0 1260 D LCL_TM DS INZ STATIC 1270 D l_sec Like(int4) 1280 D l_min Like(int4) 1290 D l_hour Like(int4) 1300 D l_mday Like(int4) 1310 D l_mon Like(int4) 1320 D l_year Like(int4) 1330 D l_wday Like(int4) 1340 D l_yday Like(int4) 1350 D l_isdst Like(int4) 1360 C Clear LCL_TM 1370 C Extrct dtVal:*DAYS nDay 1380 C Extrct dtVal:*MONTHS nMonth 1390 C Extrct dtVal:*YEARS nYear 1400 C Eval l_mon = nMonth - 1 1410 C Eval l_mDay = nDay 1420 C Eval l_Year = nYear - 1900 1430 C If %Parms >= 2 ** If the caller want's Parm2 to be updated, move it into parm2 1440 C Eval rtn_TM = LCL_TM 1450 C endif ** Return the TM structure to the caller. Useful for ** nested or in-line function calls requiring a TM structure. 1460 C return lcl_TM 1470 P DatToTM E