|
Code:
- PF DATESAMPLE:
-
- A R DATER TEXT('Sample date field comparison')
- A*
- A CHAR 10A COLHDG('Char' 'data type')
- A ALWNULL
- A DATE1 L COLHDG('Date' 'data type')
- A ALWNULL
- A DATE2 8S 0 COLHDG('Signed' 'data type')
- A EDTWRD('0 / / ')
- A ALWNULL
- A DATE4 8A COLHDG('CHAR' 'data type' )
- A TIME1 T COLHDG('Time' 'data type')
- A ALWNULL
- A TIME2 6S 0 COLHDG('Signed' 'data type')
- A EDTWRD('0 : : ')
- A ALWNULL
- A TIMEST Z COLHDG('Timestamp' 'data type')
- A ALWNULL
- A PACKED 5P 0 COLHDG('Pack' 'data type')
- A EDTCDE(M)
- A ALWNULL
- A BINARY 9B 0 COLHDG('Binary' 'data type')
- A EDTCDE(M)
- A ALWNULL
- A DATE3 L COLHDG('Date' 'data type')
- A DATFMT(*YMD)
- A DFT('99/01/01')
- A ALWNULL
- A CHARUTF8 10A COLHDG('UTF8')
- A CCSID(1208)
- A ALWNULL
- A CHARUTF16 10G COLHDG('UTF16')
- A CCSID(1200)
- A ALWNULL
-
- ADDPFTRG FILE(BUCK/datesample) TRGTIME(*BEFORE)
- TRGEVENT(*UPDATE) ALWREPCHG(*YES)
- PGM(BUCK/TRIGGER) RPLTRG(*YES)
-
- This first RPG program is part of a trigger mediator; it allows me to turn the trigger on and off via a data area instead of needing a *EXCL lock on the table to RMVPFTRG.
-
- RPGLE program TRIGGER:
-
- h dftactgrp(*no) actgrp(*CALLER) option(*srcstmt: *nodebugio)
- h bnddir('BUCK') alwnull(*usrctl)
- h debug
-
- * DBGVIEW(*list)
-
- * Sample "self-updating" trigger program. 'Self-updating' means this trigger
- * updates the file it's attached to; modifying the record being updated.
- * runs as a two part process. When the file is updated, the trigger fires and
- * executes the first program. This is an "on/off" switch, and only passes
- * parms back and forth to the second program, which actually does the trigger
- * processing.
-
- * DATESAMPLE trigger: Fires before update
- *
- * ADDPFTRG FILE(BUCK/datesample) TRGTIME(*BEFORE)
- * TRGEVENT(*UPDATE) ALWREPCHG(*YES)
- * PGM(BUCK/TRIGGER) RPLTRG(*YES)
-
- /copy qprotosrc,buck
-
- d trgBufTemplatee ds EXTNAME(Trigger)
- d trgStatus 1a dtaara('TRIGGER')
-
- d trgBuf s like(trgBufTemplate)
- d trgBufLen s 10u 0
- d trgRtnCode s 10i 0
- d callLib s 10a
- d callPgm s 10a
- d callMod s 10a
- d callPrc s 256a varying
-
- dTRIGGERRUN pr extpgm('TRIGGERRUN')
- d trgBuf like(trgBufTemplate)
- d trgBufLen 10u 0
- d trgRtnCode 10i 0
-
- dsndMsg pr
- d errMsgId like(trgRtnCode)
-
- * Input/output parameters
- c *entry plist
- c parm trgBuf
- c parm trgBufLen
-
- /free
-
- monitor;
-
- // fail silently if we can't find the data area. If we can't figure out
- // whether to fire the trigger or not, default to NOT.
- in(e) trgStatus;
- if %error();
- return;
- endif;
-
- // see if we should fire the trigger
- if trgStatus = 'Y';
- callp(e) getProcName(callLib: callPgm: callMod: callPrc);
- //dump(a);
- callp(e) TRIGGERRUN (trgBuf: trgBufLen: trgRtnCode);
-
- // fail silently if we can't run the actual trigger processing pgm
- if %error();
- return;
- endif;
-
- // trigger fell over - tell DB2 the action failed
- if trgRtnCode <> 0;
- sndMsg(trgRtnCode);
- endif;
-
- endif;
-
- // not LR, but RETURN. Saves re-initialising every time I'm called.
- return;
-
- on-error *all;
- // violates the principle of actually handling every error
- // on purpose - we want to silently fail and not break the DB
- return;
-
- endmon;
-
- /end-free
-
- psndMsg b
- dsndMsg pi
- d errMsgId like(trgRtnCode)
-
- * Send message API parameters
- * stack count reflects the fact that we need to send the message
- * up the stack; i.e. not this pgm, but its caller. Remember that we're
- * down another level because of the subprocedure...
- d msgId s 7 inz('CPF9898')
- d msgFil s 20 inz('QCPFMSG *LIBL ')
- d msgData s 80
- d msgDataLen s 10i 0 inz(%len(msgData))
- d msgType s 10 inz('*ESCAPE')
- 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
-
- dQMHSNDPM pr extpgm('QMHSNDPM')
- d msgId 7
- d msgFil 20
- d msgData 80
- d msgDataLen 10i 0
- d msgType 10
- d msgStackEnt 10
- d msgStackCnt 10i 0
- d msgKey 4
- d msgErrStruc like(errStruc)
- d
- d
-
- /free
-
- monitor;
-
- // sending an escape message tells DB2 that the update did not occur
- msgData = 'Trigger failed: ' + %trim(%char(errMsgId));
- msgErrStruc = errStruc;
-
- callp(e) QMHSNDPM (msgId:
- msgFil:
- msgData:
- msgDataLen:
- msgType:
- msgStackEnt:
- msgStackCnt:
- msgKey:
- msgErrStruc);
-
- errStruc = msgErrStruc;
-
- on-error *all;
- // violates the principle of actually handling every error
- // on purpose - we want to silently fail and not break the DB
- return;
-
- endmon;
-
- /end-free
- p e
-
- This next RPG program is the actual trigger logic. When this code issues an ESCAPE message, it percolates back to the top level program that issued the I/O which fired the trigger.
-
- RPGLE program TRIGGERRUN:
-
- h dftactgrp(*no) actgrp(*CALLER) option(*srcstmt: *nodebugio)
- h copyright('Copyright 2000, 2009 Buck Calabro')
- h debug
-
- * DBGVIEW(*list)
-
- * Sample "self-updating" trigger program
- * runs as a two part process. When the file is updated, the trigger fires and
- * executes the first program. This is an "on/off" switch, and only passes
- * parms back and forth to the second program, which actually does the trigger
- * processing.
-
- * ===========================================================
- * Specific to this DBF
- * ===========================================================
-
- * Map the file I/O buffers from the external definitions
- d OldRcdImg E DS EXTNAME(DATESAMPLE)
- d based(pOldRcd)
- d prefix(O_)
-
- d NewRcdImg E DS EXTNAME(DATESAMPLE)
- d based(pNewRcd)
- d prefix(N_)
-
- * ===========================================================
- * Generic to all triggers:
- * ===========================================================
-
- * The DS definition has a field that pushes the
- * DS length to 32766. This field is only there for
- * debugging purposes, and can be ommitted if desired.
- * Never use that field to access the buffers; always
- * use the data structures defined above with the EXTNAME
- * of the physical file being triggered.
- d TrgBuf E DS EXTNAME(Trigger)
-
- * We can't tell how many fields are in the file;
- * to avoid hard-coding the number, set up an arbitrarily large
- * array to hold the null map. Remember that you can only
- * trust the array up to the null map length!!!
- d OldNulImg ds 32766 Based(POldNul)
- d OldNulMap 1a dim(%size(OldNulImg))
- d NewNulImg ds 32766 Based(PNewNul)
- d NewNulMap 1a dim(%size(NewNulImg))
-
- * Local work variables
- d TrgBufLen S 10u 0
- d TrgRtnCde S 10i 0
-
- * Named constants
- * Commit lock level
- * *NONE, *CHG, *CS, *ALL
- d CLNONE S 1A INZ('0')
- d CLCHG S 1A INZ('1')
- d CLCS S 1A INZ('2')
- d CLALL S 1A INZ('3')
-
- * Trigger event = Insert
- * Insert, Delete, Update
- d TRGINS S 1A INZ('1')
- d TRGDEL S 1A INZ('2')
- d TRGUPD S 1A INZ('3')
-
- * Trigger time
- * Before, After
- d TRGBEF S 1A INZ('1')
- d TRGAFT S 1A INZ('2')
-
- * Null
- d NULLNO S 1A INZ('0')
- d NULLYES S 1A INZ('1')
-
- * Input/output parameters
- c *entry plist
- c parm TrgBuf
- c parm TrgBufLen
- c parm TrgRtnCde
-
-
- /FREE
- monitor;
- // Load the working record buffers and null maps
- // Reiterate the warning about obeying the limits of the buffer
- // as set by the "length" variables. Because we're using pointers,
- // we can wander off into "memory unknown" if we fail to observe
- // these limits!!!
- pOldRcd = %addr(TrgBuf)+ OldRecOff;
- pNewRcd = %addr(TrgBuf)+ NewRecOff;
-
- // To manipulate the null indicator for a field,
- // set the null map value. Don't try to fiddle with %nullind
- // because you can't have a null capable data structure subfield.
- pOldNul = %addr(TrgBuf)+ OldNulOff;
- pNewNul = %addr(TrgBuf)+ NewNulOff;
-
- // ===========================================================
- // Specific to this DBF
- // ===========================================================
-
- // Test conditions
- // NOTE NOTE NOTE - ALWAYS check the null indicator!
- if event = TRGINS or
- event = TRGUPD;
- select;
- // Here, if the name is left blank, we'll populate it
- // with an eye-catcher so we know the trigger works.
- when NewNulMap(1)=NULLNO and N_Char=*Blanks;
- N_Char='Trigger x';
- when NewNulMap(1)=NULLNO and N_Char='*blanks';
- N_Char='Trigger y';
- when NewNulMap(1)=NULLNO and N_Char='NULL';
- NewNulMap(1) = NULLYES;
- N_Char = 'Now null';
- // Here, if the name is '01', we'll fail the update
- // This is to test trigger failure
- when NewNulMap(1)=NULLNO and N_Char='01';
- trgRtnCde = 1;
- when NewNulMap(1)=NULLYES;
- NewNulMap(7) = NULLNO;
- N_Packed = 12345;
- endsl;
-
- endif;
-
- // not LR, but RETURN.
- return;
-
- on-error *all;
- // violates the principle of actually handling every error
- // on purpose - we want to silently fail and not break the DB
- trgRtnCde = -1;
- return;
-
- endmon;
-
- /END-FREE
-
- Finally, the program that tests the trigger environment. This tries to update a row in DATESAMPLE and the trigger logic is coded to check for this specific updtae, and prevent it from happening. This program receives the various messages which occur during this situation.
-
- RPGLE program TRIGTEST
-
- h/copy qrpglesrc,stdhspec
- fdatesampleuf e disk
-
- dcl-ds QUSEC qualified;
- errBytesProv int(10) inz(%size(qusec));
- errBytesAvail int(10) inz;
- errMsgID char(7);
- reserved char(1);
- errMsgDta char(512);
- end-ds;
-
- dcl-ds rcvm0200 inz qualified;
- returned int(10);
- available int(10);
- msgSev int(10);
- msgId char(7);
- msgType char(2);
- msgKey char(4);
- msgf char(10);
- msgfLib char(10);
- msgfLibUsed char(10);
- sendJob char(10);
- sendUser char(10);
- sendNbr char(6);
- sendPgm char(12);
- sendInstr char(4);
- sendDate char(7);
- sendTime char(6);
- rcvPgm char(10);
- rcvInstr char(4);
- sendType char(1);
- rcvType char(1);
- reserved char(1);
- textConvCCSID int(10);
- dataConvCCSID int(10);
- alertOpt char(9);
- msgCCSID int(10);
- dataCCSID int(10);
- dataLenReturn int(10);
- dataLenAvail int(10);
- msgLenReturn int(10);
- msgLenAvail int(10);
- helpLenReturn int(10);
- helpLenAvail int(10);
- msgData char(0512);
- message char(0512);
- msgHelp char(0512);
- end-ds;
-
- dcl-pr rcvPgmMsg extpgm('QMHRCVPM');
- messageInfo char(1) options(*varsize);
- messageInfoLen int(10) const;
- fmtName char(8) const;
- callStackEntry char(65535) const options(*varsize);
- callStackCounter int(10) const;
- msgType char(10) const;
- msgKey char(4);
- waitTime int(10) const;
- msgAction char(10) const;
- errorStruc likeds(qusec);
- end-pr;
-
- dcl-s messageInfoLen int(10) inz(%size(rcvm0200));
- dcl-s fmtName char(8) inz('RCVM0200');
- dcl-s callStackEntry char(10) inz('*');
- dcl-s callStackCounter int(10) inz(0);
- dcl-s msgType char(10) inz('*LAST');
- dcl-s msgKey char(4) inz(*blanks);
- dcl-s waitTime int(10) inz(0);
- dcl-s msgAction char(10) inz('*OLD');
-
- // this is a simple update which will fire my trigger.
- // the trigger will deliberately fall over
- chain 2 dater;
- if %found();
- char = '01';
- update(e) dater;
-
- // get the error message details
- if %error();
- // the 'C'
- rcvPgmMsg(rcvm0200: messageInfoLen: fmtName:
- callStackEntry: callStackCounter:
- msgType: msgKey: waitTime: msgAction: qusec);
- // CPF502B- Error in trigger program
- msgType = '*PRV';
- msgKey = rcvm0200.msgKey;
- rcvPgmMsg(rcvm0200: messageInfoLen: fmtName:
- callStackEntry: callStackCounter:
- msgType: msgKey: waitTime: msgAction: qusec);
- // my CPF9898 sent by the trigger - 02, diagnostic
- msgType = '*PRV';
- msgKey = rcvm0200.msgKey;
- rcvPgmMsg(rcvm0200: messageInfoLen: fmtName:
- callStackEntry: callStackCounter:
- msgType: msgKey: waitTime: msgAction: qusec);
- dump(a);
- endif;
-
- endif;
-
- *inlr = *on;
|
|