Stan Sieler ([log in to unmask]) wrote: : Larry writes: : NOTE: No AIF:PE intercept of any IMAGE intrinsic will catch any calls : from CM!!!! : This is because CM IMAGE intrinsics switch to NM and call something : *below* the DBUPDATE/DB... intrinsic (e.g., on the order of: nmdbupdate, : which is the real worker for dbupdate. THis linkage is somewhat : hardwired, and difficult to intercept. I did some research a year or : two ago, and developed a method of intercepting the common routine that : the CM IMAGE intrinsics call on their way to the "worker" IMAGE : routine, but didn't do robust testing. : I started to urge HP to provide a more useful "hook" for intercepting : *all* IAMGE calls a few years ago, but the concept got lost in the : work on jumbo datasets. With mostly documentation work, it would be : fairly easy to allow all IMAGE calls to be intercepted via AIF:PE : by documenting & "marking" a small set of routines, ala what AIF:PE : did for selected routines within NL.PUB.SYS. : -- : Stan Sieler [log in to unmask] : http://www.allegro.com/sieler.html While Stan's description of what is happening during the CM to NM switch is accurate, there is a way to trap CM IMAGE intrinsics. The routine you would enable a trap for is "nmtw_fs_stub" in XL.PUB.SYS. This is not a convientent method, like Stan, I also would prefer a more useful hook but so far it has not happened. Below I have include the CM section of some IMAGE trap procedures I wrote for a customer. If you have any questions please feel free to e-mail me. program pascal_database_traps; $page$ { ---------------------------------------------------------------------------- } { } { } { ---------------------------------------------------------------------------- } const PC_DBOPEN = 401; PC_DBINFO = 402; PC_DBCLOSE = 403; PC_DBFIND = 404; PC_DBGET = 405; PC_DBUPDATE = 406; PC_DBPUT = 407; PC_DBDELETE = 408; PC_DBLOCK = 409; PC_DBUNLOCK = 410; PC_DBCONTROL = 411; PC_DBBEGIN = 412; PC_DBEND = 413; PC_DBMEMO = 414; PC_DBEXPLAIN = 418; PC_DBERROR = 419; PC_DBXBEGIN = 420; PC_DBXEND = 421; PC_DBXUNDO = 422; Q_MINUS_4 = -(4 * 2); Q_MINUS_5 = -(5 * 2); Q_MINUS_6 = -(6 * 2); TI_MAX_DATA_ENTRIES = 255; TI_MAX_DATA_ITEMS = 1023; TI_MAX_DATA_SETS = 199; $page$ { ---------------------------------------------------------------------------- } { } { } { ---------------------------------------------------------------------------- } type pac2 = packed array [1..2] of char; pac4 = packed array [1..4] of char; pac8 = packed array [1..8] of char; pac10 = packed array [1..10] of char; pac16 = packed array [1..16] of char; pac18 = packed array [1..18] of char; pac26 = packed array [1..26] of char; pac34 = packed array [1..34] of char; pac37 = packed array [1..37] of char; pac200 = packed array [1..200] of char; pac800 = packed array [1..800] of char; pac1024 = packed array [1..1024] of char; pac2048 = packed array [1..2048] of char; aifpe_filename_t = pac37; aifpe_procname_t = pac34; aifpe_prodname_t = pac4; bit8 = 0..255; bit16 = 0..65535; cm_parm_area_t = record db : globalanyptr; q : localanyptr; cm_global_addr : localanyptr; end; db_address_t = array [ 1..8 ] of localanyptr; dbbuffer_t = $ALIGNMENT 2$ pac1024; dbbuffer_ptr_t = ^dbbuffer_t; dblist_t = record case boolean of TRUE : (items : pac2048); FALSE : (nbritems : shortint; itemno : array [1..TI_MAX_DATA_ENTRIES] of shortint); end; dblist_ptr_t = ^dblist_t; dbmode_t = shortint; dbmode_ptr_t = ^dbmode_t; dbname_t = packed record fileno : shortint; name : pac26; end; dbname_ptr_t = ^dbname_t; dbpass_t = pac8; dbpass_ptr_t = ^dbpass_t; dbset_t = record case boolean of TRUE : (setname : pac16); FALSE : (setnbr : shortint); end; dbset_ptr_t = ^dbset_t; { Due to some PASCAL alignment nightmares in 4.0, we had to } { make the dbstatus data type CRUNCHED to try and force byte } { alignment. In 5.0 this does not seem to be a problem so } { you do not need to make this CRUNCHED. But test it to make } { sure. } { ----------------------------------------------------------- } dbstatus_t = crunched record word1 : shortint; word2 : shortint; word3_4 : integer; word5 : shortint; word6 : shortint; word7 : shortint; word8 : shortint; word9 : shortint; word10 : shortint; end; dbstatus_ptr_t = ^dbstatus_t; dbdelete_parms_t = record dbstatus_ptr : dbstatus_ptr_t; dbmode_ptr : dbmode_ptr_t; dbset_ptr : dbset_ptr_t; dbname_ptr : dbname_ptr_t; end; dbdelete_parms_ptr_t = ^dbdelete_parms_t; dbopen_parms_t = record dbstatus_ptr : dbstatus_ptr_t; dbmode_ptr : dbmode_ptr_t; dbpass_ptr : dbpass_ptr_t; dbname_ptr : dbname_ptr_t; end; dbopen_parms_ptr_t = ^dbopen_parms_t; dbput_parms_t = record dbbuffer_ptr : dbbuffer_ptr_t; dblist_ptr : dblist_ptr_t; dbstatus_ptr : dbstatus_ptr_t; dbmode_ptr : dbmode_ptr_t; dbset_ptr : dbset_ptr_t; dbname_ptr : dbname_ptr_t; end; dbput_parms_ptr_t = ^dbput_parms_t; dbupdate_parms_t = record dbbuffer_ptr : dbbuffer_ptr_t; dblist_ptr : dblist_ptr_t; dbstatus_ptr : dbstatus_ptr_t; dbmode_ptr : dbmode_ptr_t; dbset_ptr : dbset_ptr_t; dbname_ptr : dbname_ptr_t; end; dbupdate_parms_ptr_t = ^dbupdate_parms_t; dbset_info_t = packed record name : pac16; typ : pac2; entry_length : shortint; block_factor : shortint; filler_12 : shortint; filler_13 : shortint; nbr_entries : integer; capacity : integer; end; q_address_t = array [ 1..8 ] of ^shortint; status_t = record case boolean of TRUE : (all : integer); FALSE : (info : shortint; subsys : shortint); end; $page$ { ---------------------------------------------------------------------------- } { } { } { ---------------------------------------------------------------------------- } procedure nmtw_fs_stub (cm_global_addr : localanyptr; q_sub : localanyptr; db_addr : globalanyptr); external; $page$ { ---------------------------------------------------------------------------- } { } { ---------------------------------------------------------------------------- } procedure pe_cm_dbtrap ( bindid : integer; var stubout : boolean; parms_area : localanyptr ) option extensible 3; $call_privilege 3$ $exec_privilege 2$ var cm_parm_area : ^cm_parm_area_t; db_address : db_address_t; i : integer; num_parms : integer; proc_code : integer; q_address : q_address_t; q_4 : ^bit16; q_5 : ^bit16; user_priv_level : integer; begin { All CM Image intrinsics will be trapped since we may not be interested in } { all of them we will default with not stubbing out the call. } { ------------------------------------------------------------------------- } stubout := FALSE; $push, type_coercion 'Representation'$ { Grab the pointer to the parameters passed } { ----------------------------------------- } cm_parm_area := ADDTOPOINTER (parms_area, -SIZEOF (cm_parm_area_t)); { Get the pointer to CM Q-4, this contains the callers privilege level } { -------------------------------------------------------------------- } q_4 := ADDTOPOINTER (cm_parm_area^.q, Q_MINUS_4); user_priv_level := q_4^; { Get the pointer to CM Q-5, this contains the id number of the intrinsic } { ----------------------------------------------------------------------- } q_5 := ADDTOPOINTER (cm_parm_area^.q, Q_MINUS_5); proc_code := q_5^; { Continue only if we are interested in the trapped intrinsic } { ----------------------------------------------------------- } if (proc_code in [PC_DBOPEN, PC_DBPUT, PC_DBUPDATE, PC_DBDELETE]) then begin { Now we need to know how many paramters are really passed to the intrinisc } { ------------------------------------------------------------------------- } case proc_code of PC_DBBEGIN, PC_DBEND, PC_DBMEMO , PC_DBINFO, PC_DBXBEGIN, PC_DBXEND, PC_DBXUNDO : num_parms := 5; PC_DBCLOSE, PC_DBCONTROL, PC_DBDELETE, PC_DBLOCK, PC_DBOPEN, PC_DBUNLOCK: num_parms := 4; PC_DBFIND, PC_DBPUT, PC_DBUPDATE: num_parms := 6; PC_DBGET : num_parms := 7; otherwise num_parms := 0; end; { We need to get the pointers to the parameters passed. To do this the } { pointer to the correct location in the Q area must be obtained. This } { pointer contains an offset that must be added to the CM DB area. } { --------------------------------------------------------------------- } for i := 1 to num_parms do begin q_address [ i ] := ADDTOPOINTER (cm_parm_area^.q, -2 * (5 + i)); db_address[ i ] := ADDTOPOINTER (cm_parm_area^.db, 2 * (q_address[ i ]^)); end; { Check to see if this call needs to be processed locally. } { -------------------------------------------------------- } case proc_code of PC_DBOPEN: begin { Perform any processing before the call. } nmtw_fs_stub (cm_parm_area^.cm_global_addr, cm_parm_area^.q, cm_parm_area^.db); { Perform andy processing after the call here. } stubout := TRUE; end; PC_DBDELETE: begin { Perform any processing before the call here. } nmtw_fs_stub (cm_parm_area^.cm_global_addr, cm_parm_area^.q, cm_parm_area^.db); { Perform andy processing after the call here. } stubout := TRUE; end; PC_DBPUT: begin { Perform any processing before the call here. } nmtw_fs_stub (cm_parm_area^.cm_global_addr, cm_parm_area^.q, cm_parm_area^.db); { Perform andy processing after the call here. } stubout := TRUE; end; PC_DBUPDATE: begin { Perform any processing before the call here. } nmtw_fs_stub (cm_parm_area^.cm_global_addr, cm_parm_area^.q, cm_parm_area^.db); { Perform andy processing after the call here. } stubout := TRUE; end; otherwise begin end; end; end; $pop$ end; $page$ { ---------------------------------------------------------------------------- } begin end. -- +----------------------------+------------------------------------------+ | Barry Lemrow | Disclaimer: | | Technical Consultant | "Opinions expressed are mine and not | | SAP National Practice | necessarily those of my employer, | | Hewlett-Packard | family, or friends!" | | [log in to unmask] | +----------------------------+------------------------------------------+ | You can't have something for nothing. You can't get freedom for free.| | You won't get wise with the sleep still in your eyes, no matter what | | your dream might be! -- N. Peart, "Something for Nothing" | +----------------------------+------------------------------------------+