AW: procedure to return calling pgm name

[Werner Noll <werner.noll@xxxxxxxxx>]

Paul,

I recently created a service procedure as test for this issue; it's not in
our production yet. It's based on the new API QWVRCSTK. I hope it can help
you to build your own solution.



 * Prototype for YRtvCaller
D YRtvCaller      PR                  Like($RtvCaller)

 *------------------------------------------------------------
 * Global Variables
 *------------------------------------------------------------
D $APIError       DS
D  yAPIDSLen                    10U 0 Inz(%size($APIError))
D  yAPIByteRtn                  10U 0 Inz
D  yAPICPFMsgID                  7A
D  yAPIReserved                  1A
D  yAPIMsgDta                  132A

D $RtvCaller      DS
D  yCallPgm                     10A
D  yCallPgmLib                  10A
D  yCallMod                     10A
D  yCallModLib                  10A
D  yCallActGrp                  10A
D  yCallProc                    15A

D $CSTK0100_1     DS          5000
D  yyBytRtn                     10I 0
D  yyBytAvl                     10I 0
D  yyEntries                    10I 0
D  yyOffset                     10I 0
D  yyEntryCount                 10I 0

D $CSTK0100_2     DS           256
D  yyEntryLen                   10I 0
D  yyDspmntStmt                 10I 0
D  yyNbrStmt                    10I 0
D  yyDspmntPrc                  10I 0
D  yyLenPrc                     10I 0
D  yyReqLvl                     10I 0
D  yyPgmNam                     10A
D  yyPgmLib                     10A
D  yyMIInstr                    10I 0
D  yyModNam                     10A
D  yyModLib                     10A
D  yyCtlBdry                     1A
D  yyReserved                    3A
D  yyActGrpNbr                  10U 0
D  yyActGrpNam                  10A
*****************************************************************
* Procedure: YRtvCaller                                         *
* Function : Retrieve information on calling program            *
*                                                               *
*            This procedure returns a DS with informations      *
*            on the application program, which has called       *
*            the program where this procedure was executed.     *
*            Programs from library QSYS are ignored.            *
*                                                               *
* Returnval: $RtvCaller                                         *
*              yCallPgm      Program (or Serviceprogram)        *
*              yCallPgmLib   Program Library                    *
*              yCallMod      Module (if ILE Program)            *
*              yCallModLib   Module Library (if ILE Program)    *
*              yCallActGrp   Activation Group                   *
*              yCallProc     Procedure (if ILE Program)         *
*                                                               *
 * Author   : Werner Noll
 ****************************************************************
P YRtvCaller      B                   Export

D YRtvCaller      PI                  Like($RtvCaller)

D QWVRCSTK        PR                  ExtPgm('QWVRCSTK')
D                             5000A
D                               10I 0
D                                8A   Const
D                               56A
D                                8A   Const
D                               15A

D #VarLen         S             10I 0 Inz(%size($CSTK0100_1))
D i1              S              5U 0
 D JobIdInf        DS
 D  JIDQName                     26    Inz('*')
 D  JIDIntID                     16
 D  JIDRes3                       2    Inz(*loval)
 D  JIDThreadInd                 10I 0 Inz(1)
 D  JIDThread                     8    Inz(*loval)

  /free

   CallP QWVRCSTK($CSTK0100_1:#VarLen:'CSTK0100':JobIdInf:'JIDF0100':
                 $APIError);

   For i1= 1 to yyEntryCount;
       $CSTK0100_2 = %subst($CSTK0100_1:yyOffset + 1);

       If yyDspmntPrc <> *zeros;
          yCallProc=%subst($CSTK0100_2:(yyDspmntPrc + 1):yyLenPrc);
      Else;
         yCallProc=*blanks;
      Endif;
      yyOffset = yyOffset + yyEntryLen;


      If yCallProc='YRTVCALLER' or yyPgmLib='QSYS';
         Iter;
      Endif;

      yCallPgm=yyPgmNam;
      yCallPgmLib=yyPgmLib;
      yCallMod=yyModNam;
      yCallModLib=yyModLib;
      yCallActGrp=yyActGrpNam;

      Leave;

  EndFor;

  Return $RtvCaller;

 /end-free

P YRtvCaller      E

Kind Regards,

GEFIS Gesellschaft für
Individual-Software mbH
Werner Noll

-----Ursprüngliche Nachricht-----
Von: Paul Jackson [mailto:paulgjackson@yahoo.com]
Gesendet: Dienstag, 24. September 2002 08:47
An: RPG400-L@midrange.com
Betreff: procedure to return calling pgm name


Hello,
I would like to write a service program procedure that
returns the name of the program that is calling the
program that is invoking the procedure. In other words
something like the following:

D CallingPgm      S   10A
 /Free
   CallingPgm = RtvCallingPgm();
   if callingpgm = 'QCMD';
     do something ;
   endif;

 /End-Free

Is there a relatively simple technique for doing this?
I know you can use SNDPGMMSG/RCVMSG or equivalent and
interrogate the SENDER info, but was wondering if
there's a more elagant solution that has arrived on
the scene with ILE and V5r1.

Also the CL RETURN command does not support a return
variable, is there a way to write a procedure in CL
and have it function as shown in the example above?

Thanks in advance,

-Paul

=====
Help prevent pet overpopulation. Please spay & neuter your pets.
http://www.doghause.com/neuter.html
http://www.fixcats.com

__________________________________________________
Do you Yahoo!?
New DSL Internet Access from SBC & Yahoo!
http://sbc.yahoo.com
_______________________________________________
This is the RPG programming on the AS400 / iSeries (RPG400-L) mailing list
To post a message email: RPG400-L@midrange.com
To subscribe, unsubscribe, or change list options,
visit: http://lists.midrange.com/cgi-bin/listinfo/rpg400-l
or email: RPG400-L-request@midrange.com
Before posting, please take a moment to review the archives
at http://archive.midrange.com/rpg400-l.