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" |
+----------------------------+------------------------------------------+
|
