Below are select sample subroutines. All 3GL reference examples for subroutines (as well as Exit, RPC and API examples) are delivered within the etc/src3gl sub directory and z/OS PDS locations and names as noted in the reference samples below (and in other examples in this manual). One reference example is actual several different language implementations (C, C++, Fortran, Cobol, BAL, Basic, RPG, PL/1 and Pascal) of a fairly simple task, translate a number into a spelled out month name (mthname). The different language implementations allow one to focus on the implementation issues in a language they may be more familiar with. The other example is a string reversing example that accounts for how to handle Unicode UTF-8 (UREVERSE) which is strictly a C example. Each has been tested and works for its given target environment.
Note that some of the samples have comments within them about portions that need to be adjusted to account for known language implementation differences on some platforms. For example, IBM i COBOL requires a change in the PROGRAM-ID specification to force a lower case entry point name and OpenVMS doesn't support GOBACK. As stated earlier, in theory any compiled and linked languages that can create a DLL can be used to create subroutines. Once a program is built as a DLL, the loading and execution process is generally agnostic of the original language.
Please note that while VB is a popular language, VB does not have options for generating a true WIN32 Dynamic Link Library (DLLs with .dll extensions) and, as such, cannot be used for building subroutines because the loader process requires that only standard DLL objects be used. This is considered a Microsoft issue. Also note that an internet search for "build dll in vb" yields a number of sites that describe how to force VB to create DLLs. While such techniques seem promising for customers who want to use VB, and may very well execute properly, IBI cannot officially support unsupported techniques. However, we will work with customers to resolve problems within this scope.
Some language samples (Pascal for instance) may not be capable of being build by GENCPGM for a given platform (ie UNIX and Linux), but is still provided on the media for all platforms for reference purposes and for people that decide to create their own build scripts.
The disk locations below, use PDS notation for PDS Deployment and UNIX notation for "all other platforms" for the purpose of being brief. The locations for Windows would be the same except the slashes are back slashes. The locations for OpenVMS would be dots instead of slashes and the directory portion would be enclosed in square braces.
Any of the MTHNAME sample routines can be tested by creating a simple FOCEXEC and using the following sample steps:
Create FOCEXEC mthname.fex
-SET &MTHNAME = MTHNAME(&MTHNUMBER,'A12') ; -TYPE Month &MTHNUMBER is &MTHNAME
Compile and set IBICPG (this is using the C example on UNIX):
export EDAHOME=/home/iadmin/ibi/srv76/home gencpgm.sh -m cpgm mthname.c export IBICPG=`pwd`
After restarting the server, execute an RPC like:
EX MTHNAME MTHNUMBER=4
And receive:
Month 4 is March
Notes:
Source:
/* */ /* MTHNAME: Sample User Written Routine in C */ /* */ /* iWay/EDA refers to these as User Written Routines */ /* and WebFOCUS/FOCUS refers to them as FUSELIBs */ /* Routines. They are written in the same way for all */ /* platforms and products, but the compilation and */ /* link steps may differ depending on release and */ /* product level. See appropriate platform/product */ /* documentation for compilation and link instructions. */ /* */ void mthname(double *mth, char *month) { static char *nmonth[13] = {"** Error **", "January ", "February ", "March ", "April ", "May ", "June ", "July ", "August ", "September ", "October ", "November ", "December ",}; int imth, loop; imth = (int)*mth; imth = (imth < 1 || imth > 12 ? 0:imth); for (loop=0;loop < 12;++loop) month[loop] = nmonth[imth][loop]; return; }
Notes:
Source:
// MTHNAME: Sample User Written Routine in C++ // Warning: Use on MVS OE requires extension to be renamed as .C extern "C" int mthname(double* mth, char* month) { const char *nmonth[13] = {"** Error **", "January ", "February ", "March ", "April ", "May ", "June ", "July ", "August ", "September ", "October ", "November ", "December ",}; int imth, loop; imth = (int)*mth; imth = (imth < 1 || imth > 12 ? 0:imth); for (loop=0;loop < 12;++loop) month[loop] = nmonth[imth][loop]; return 0; }
Notes:
Source:
SUBROUTINE MTHNAME (MTH,MONTH) REAL*8 MTH INTEGER*4 MONTH(3),A(13,3),IMTH DATA + A( 1,1)/'Janu'/, A( 1,2)/'ary '/, A( 1,3)/' '/, + A( 2,1)/'Febr'/, A( 2,2)/'uary'/, A( 2,3)/' '/, + A( 3,1)/'Marc'/, A( 3,2)/'h '/, A( 3,3)/' '/, + A( 4,1)/'Apri'/, A( 4,2)/'l '/, A( 4,3)/' '/, + A( 5,1)/'May '/, A( 5,2)/' '/, A( 5,3)/' '/, + A( 6,1)/'June'/, A( 6,2)/' '/, A( 6,3)/' '/, + A( 7,1)/'July'/, A( 7,2)/' '/, A( 7,3)/' '/, + A( 8,1)/'Augu'/, A( 8,2)/'st '/, A( 8,3)/' '/, + A( 9,1)/'Sept'/, A( 9,2)/'embe'/, A( 9,3)/'r '/, + A(10,1)/'Octo'/, A(10,2)/'ber '/, A(10,3)/' '/, + A(11,1)/'Nove'/, A(11,2)/'mber'/, A(11,3)/' '/, + A(12,1)/'Dece'/, A(12,2)/'mber'/, A(12,3)/' '/, + A(13,1)/'**ER'/, A(13,2)/'ROR*'/, A(13,3)/'* '/ IMTH=MTH+0.000001 IF (IMTH .LT. 1 .OR. IMTH .GT. 12) IMTH=13 DO 1 I=1,3 1 MONTH(I)=A(IMTH,I) RETURN END
Notes: Some Fortran compilers support character variables longer than 4 bytes and, in this case, the example’s array could be constructed as a CHARACTER*10 with A(1)/’January’/, ..., A(13)/’***ERROR**’/ syntax, but the split array syntax used in example above is known to work on all Fortran compilers.
Notes:
Source:
000100* 000200 IDENTIFICATION DIVISION. 000300* 000400* MTHNAME: Sample User Written Routine in Cobol 000500* 000600* Notes: 000700* 000800* 1. This sample is based on the original mainframe 000900* sample with a PROGRAM-ID of MTHNAM. This has been 001000* changed to have a uniquely sourced version that 001100* more closely matches the C version and has these 001200* comments. The samples are otherwise the same. 001300*
001400* 2. Original mainframe sample had a GOBACK as the 001500* last statement. OpenVMS Cobol seems to object 001600* to this, so commented it out as noted below. 001700* Unix compiler support for GOBACK may also vary 001800* by vendor and untested at this time (5/1/2003). 001900*
002000* 3. OpenVMS compiled and was found, but initial 002100* always returned the error case. This was 002200* actually a GENCPGM.COM error that the Cobol 002300* needed the /FLOAT=G_FLOAT switch, so be sure 002400* that you are using a GENCPGM.COM from 5.2.3 002500* or higher where this is fixed. 002600*
002700* 4. The PROGRAM-ID name may also needed some 002800* special handling depending on the platform. 002900* The reason for this is that iWay routines 003000* are searched for in lower case and there 003100* seems to be some case sensitivity problems 003200* for the platforms tested so far. OpenVMS 003300* doesn't seem to care if name is lower or 003400* upper case. i5/OS Cobol is not only case 003500* sensitive but requires explicit lower case 003600* values to be in single quotes, but also 003700* needs the compiler option *NOMONOPRC to 003800* respect the coded value. So, depending 003900* on your platform, the PROGRAM-ID value may 004000* need editing as per notes below. 004100* 004800*
004900* ID Usage for Mainframe and OpenVMS ... 005000*PROGRAM-ID. MTHNAME. 005100* ID Usage for Unix and Windows ... 005200*PROGRAM-ID. mthname. 005300* ID Usage for i5/OS ... 005400*PROGRAM-ID. 'mthname'. 005500* 005600* ID Usage for this run ... 005700 PROGRAM-ID. mthname. 005800*
005900 ENVIRONMENT DIVISION. 006000 CONFIGURATION SECTION. 006100 DATA DIVISION. 006200 WORKING-STORAGE SECTION. 006300 01 MONTH-TABLE. 006400 05 FILLER PIC X(9) VALUE 'January '. 006500 05 FILLER PIC X(9) VALUE 'February '. 006600 05 FILLER PIC X(9) VALUE 'March '. 006700 05 FILLER PIC X(9) VALUE 'April '. 006800 05 FILLER PIC X(9) VALUE 'May '. 006900 05 FILLER PIC X(9) VALUE 'June '. 007000 05 FILLER PIC X(9) VALUE 'July '. 007100 05 FILLER PIC X(9) VALUE 'August '. 007200 05 FILLER PIC X(9) VALUE 'September'. 007300 05 FILLER PIC X(9) VALUE 'October '. 007400 05 FILLER PIC X(9) VALUE 'November '. 007500 05 FILLER PIC X(9) VALUE 'December '. 007600 05 FILLER PIC X(9) VALUE '**ERROR**'. 007700 01 MLIST REDEFINES MONTH-TABLE. 007800 05 MLINE OCCURS 13 TIMES INDEXED BY IX. 007900 10 A PIC X(9). 008000 01 IMTH PIC S9(5) COMP.
008100 LINKAGE SECTION. 008200 01 MTH COMP-2. 008300 01 MONTH PIC X(9). 008400 PROCEDURE DIVISION USING MTH, MONTH. 008500 BEG-1. 008600 ADD 0.000001 TO MTH. 008700 MOVE MTH TO IMTH. 008800 IF IMTH < +1 OR > 12 008900 SET IX TO +13 009000 ELSE 009100 SET IX TO IMTH. 009200 MOVE A (IX) TO MONTH. 009300* 009400* On OpenVMS ... Comment out the GOBACK. 009500* 009600 GOBACK.
Notes:
Source:
* * MTHNAME: Sample User Written Routine in z/OS BAL Assembler * * If this is used as a source read directly from an HFS file * system the extension must be .x for assembler files. * MTHNAME CSECT MTHNAME AMODE 31 MTHNAME RMODE ANY STM 14,12,12(13) save registers BALR 12,0 load base reg USING *,12 * L 3,0(0,1) load addr of first arg into R3 LD 4,=D'0.0' clear out FPR4 and FPR5 LE 6,0(0,3) FP number in FPR6 LPER 4,6 abs value in FPR4 AW 4,=D'0.00001' add rounding constant AW 4,DZERO shift out fraction STD 4,FPNUM move to memory L 2,FPNUM+4 integer part in R2 TM 0(3),B'10000000' check sign of original no BNO POS branch if positive LCR 2,2 complement if negative * POS LR 3,2 copy month number into R3 C 2,=F'0' is it zero or less? BNP INVALID yes. so invalid C 2,=F'12' is it greater than 12? BNP VALID no. so valid INVALID LA 3,13(0,0) set R3 to point to item @13 (error) *
VALID SR 2,2 clear out R2 M 2,=F'9' multiply by shift in table * LA 6,MTH(3) get addr of item in R6 L 4,4(0,1) get addr of second arg in R4 MVC 0(9,4),0(6) move in text * LM 14,12,12(13) recover regs BR 14 return * DS 0D alignment FPNUM DS D floating point number DZERO DC X'4E00000000000000' shift constant MTH DC CL9'dummyitem' month table DC CL9'January' DC CL9'February' DC CL9'March' DC CL9'April' DC CL9'May' DC CL9'June' DC CL9'July' DC CL9'August' DC CL9'September' DC CL9'October' DC CL9'November' DC CL9'December' DC CL9'**ERROR**' END MTHNAME
Notes:
Source:
1000 SUB mthname BY REF(REAL MTH, STRING MONTH = 12) 1001 REM 1002 REM MTHNAME: Sample User Written Routine in Basic 1003 REM This sample is based on FOCUS/VMS 6.x sample. 1004 REM 1005 REM Only changes were to make it more like the standard 1006 REM sample (entry point of lowercase mthname (vs. MTHNAM) 1007 REM datatype of REAL (vs. DOUBLE) and use mixed case 1008 REM month names. 1009 REM 2000 ON INTEGER(MTH) GOTO 2001,2002,2003,2004,2005,2006, & 2007,2008,2009,2010,2011,2012 & OTHERWISE 2013 2001 MONTH = "January" \ EXIT SUB 2002 MONTH = "February" \ EXIT SUB 2003 MONTH = "March" \ EXIT SUB 2004 MONTH = "April" \ EXIT SUB 2005 MONTH = "May" \ EXIT SUB 2006 MONTH = "June" \ EXIT SUB 2007 MONTH = "July" \ EXIT SUB 2008 MONTH = "August" \ EXIT SUB 2009 MONTH = "September" \ EXIT SUB 2010 MONTH = "October" \ EXIT SUB 2011 MONTH = "November" \ EXIT SUB 2012 MONTH = "December" \ EXIT SUB 2013 MONTH = "** Error **" \ EXIT SUB 3000 END SUB
Notes:
Source:
HNOMAIN * MTHNAME: Sample User Written Routine in RPG * Converts month number to month name * This is an IBM i RPG version of the standard mthname.c * sub routine supplied with IBI products.
* This a no main dll service type program with a lowercase * exported symbol ... which is what is needed to integrate * with programs that typically use lower or mixed case * symbols in there dlls (ie. C).
* This routine is stored for z/OS PDS Deployment purposes * as MTHNAMRP so it does not conflict with any of the * other MTHNAME samples. Gencpgm on z/OS doesn't support * RPG so building there is a non issue.
* Declare procedure parameter prototype. * EXTPROC needed for lower case symbol ... very important! D mthname PR EXTPROC('mthname') D MTH 8F D MTHNAME 11A
* Procedure begin with external symbol export declaration. P mthname B EXPORT
* Declare procedure parameter interface. D mthname PI D MTH 8F D MTHNAME 11A * Error Cases ... check if below 1 or above 12 C IF MTH < 1 OR MTH > 12 C MOVE '** Error **' MTHNAME C ENDIF
* Look up by month ... * (Using LOOKUP would be better, but lets keep it simple) C IF MTH = 1 C MOVE 'January ' MTHNAME C ENDIF C IF MTH = 2 C MOVE 'February ' MTHNAME C ENDIF C IF MTH = 3 C MOVE 'March ' MTHNAME C ENDIF C IF MTH = 4 C MOVE 'April ' MTHNAME C ENDIF C IF MTH = 5 C MOVE 'May ' MTHNAME C ENDIF C IF MTH = 6 C MOVE 'June ' MTHNAME C ENDIF C IF MTH = 7 C MOVE 'July ' MTHNAME C ENDIF C IF MTH = 8 C MOVE 'August ' MTHNAME C ENDIF C IF MTH = 9 C MOVE 'September ' MTHNAME C ENDIF C IF MTH = 10 C MOVE 'October ' MTHNAME C ENDIF C IF MTH = 11 C MOVE 'November ' MTHNAME C ENDIF C IF MTH = 12 C MOVE 'December ' MTHNAME C ENDIF * Done; return to caller. C RETURN * Procedure End P E
Notes:
Source:
/* MTHNAME: Sample User Written Routine in PL/1 */ MTHNAME: PROC(MTHNUM,FULLMTH) OPTIONS(COBOL); DECLARE MTHNUM DECIMAL FLOAT (16) ; DECLARE FULLMTH CHARACTER (9) ; DECLARE MONTHNUM FIXED BIN (15,0) STATIC ; DECLARE MONTH_TABLE(13) CHARACTER (9) STATIC INIT ('January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October', 'November', 'December', '**ERROR**') ; MONTHNUM = MTHNUM + 0.00001 ; IF MONTHNUM < 1 | MONTHNUM > 12 THEN MONTHNUM = 13 ; FULLMTH = MONTH_TABLE(MONTHNUM) ; RETURN ; END MTHNAME ;
Notes:
Source:
{ MTHNAME: Sample User Written Routine in Pascal This sample is based on FOCUS/VMS 6.x sample. Only changes were to make it more like the standard C sample (entry point of lowercase mthname (vs. MTHNAM) and use mixed case month names). } MODULE MTH; TYPE monthstring = packed array [1..12] OF CHAR; [GLOBAL] PROCEDURE mthname(MTH:double ; var month : monthstring); VAR IMONTH :INTEGER; BEGIN IMONTH:= ROUND(MTH); IF IMONTH IN [1..12] THEN CASE IMONTH OF 1 : MONTH := 'January'; 2 : MONTH := 'February'; 3 : MONTH := 'March'; 4 : MONTH := 'April'; 5 : MONTH := 'May'; 6 : MONTH := 'June'; 7 : MONTH := 'July'; 8 : MONTH := 'August'; 9 : MONTH := 'September'; 10 : MONTH := 'October'; 11 : MONTH := 'November'; 12 : MONTH := 'December'; END ELSE MONTH := '** Error **' END; END.
Notes:
/* */ /* Sample User Written Routine in C ... */ /* UREVERSE: Unicode UTF-8 capable string reversing routine */ /* */ /* Typical usage: */ /* -SET &STRING = 'abcd' ; */ /* -SET &RSTRING = UREVERSE(&STRING,&STRING.LENGTH,&FOCCODEPAGE,A&STRING.LENGTH) ; */ /* -TYPE Reverse of &STRING is &RSTRING */ /* Note: &FOCCODEPAGE is standard amper variable for server code page */ /* */
/* Servers using the Unicode 65002 page are effectively UTF-EBCDIC and beyond */ /* the scope of this simple sample. Customer implementations should follow the */ /* information at http://www.unicode.org/reports/tr16 when using the 65002 */ /* UTF-EBCDIC code page. */
#include <stdio.h> #include <stdlib.h>
void ureverse( char *instr, double *charsize, double *codepage, char *outstr ) { unsigned short codepg = (unsigned short)*codepage; int csize = (int)*charsize; int bsize, offset, clen, ccnt; unsigned char *cptr; char *foccodepage;
/* External var override, normally var is not set. If trying to make an */ /* existing routine Unicode compliant without passing an extra var, this */ /* method can be used to get a code page value if following is added to */ /* the server profile (edasprof) or other application code: */ /* -SET &RC = FPUTENV(11,'FOCCODEPAGE',&FOCCODEPAGE.LENGTH,&FOCCODEPAGE,D8) ; */
foccodepage = getenv("FOCCODEPAGE"); if( foccodepage != NULL ) { codepg = atoi( foccodepage ); }
if( codepg == 65001 ) /* Unicode reference number used by server for UTF-8 */ { /* Unicode UTF-8 */ /* Pass 1. Calculate the byte length of 'instr' in character length 'charsize' */ /* Pass 2. Copy each character from 'instr' to 'outstr' in reverse */ bsize = csize * 3; /* maximum byte size */ for( ccnt = offset = 0; ccnt < csize && offset < bsize; ccnt++, offset += clen ) { cptr = (unsigned char *)&instr[offset]; if( *cptr < 0x80 ) clen = 1; else if( *cptr < 0xE0 ) clen = 2; else clen = 3; } bsize = offset; /* actual byte size in utf-8 for charsize */ for( offset = 0; offset < bsize; offset += clen ) { cptr = (unsigned char *)&instr[offset]; if( *cptr < 0x80 ) clen = 1; else if( *cptr < 0xE0 ) clen = 2; else clen = 3; memcpy( &outstr[bsize - offset - clen ], cptr, clen ); } } else { /* Non-Unicode */ /* Copy each character from 'instr' to 'outstr' in reverse */ for( offset = 0; offset < csize; offset++ ) { outstr[csize - offset - 1] = instr[offset]; } } }
iWay Software |