QSYGETPH - (A example of RPGLE)

      QSYGETPH - (RPGLE)

 

      **************************************************************************
      * Swaps a user profile from the current job from one user to another
      *
      *    You MUST pass the user profile and password for that user to this
      *    program in order to change the job to that user
      *
      **************************************************************************
      *
      *  To Create:  CrtBndRPG(*LIBL/SWAPUSRPRF)
      *
      ***************************************************************************
     H DFTACTGRP(*NO) BNDDIR('QC2LE')
     D RtvProfile      PR            10I 0
     D   userid                      10A   value
     D   password                    10A   value
      *
     D SetUProf        PR            10I 0
     D   handle                      12A   value
      *
     D Handle          S             12A
      *
     D RC              S             10I 0
     D LC              C                   'abcdefghijklmnopqrstuvwxyz'
     D UC              C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
      *

      **----------------------------------------------------------------
      **  Get Profile Handle API
      **
      **   Parameters:
      **      UserID = userid to retrieve a profile handle for
      **    Password = password of the user-id above
      **      Handle = the profile handle that's returned.
      **   ErrorCode = API error code, used to return any errors.
      **
      **----------------------------------------------------------------
     D GetProfile      PR                  ExtPgm('QSYGETPH')
     D   UserID                      10A   const
     D   Password                    10A   const
     D   Handle                      12A
     D   ErrorCode                32766A   options(*varsize: *nopass)


      **----------------------------------------------------------------
      **  Set User Profile API:
      **
      **   Parms:
      **      Handle = User Profile handle (returned by QSYGETPH API)
      **   ErrorCode = standard API error code structure
      **
      **----------------------------------------------------------------
     D SetProfile      PR                  ExtPgm('QWTSETP')
     D   Handle                      12A   const
     D   ErrorCode                32766A   options(*varsize: *nopass)

     D ErrDs           DS
     D  BytesPrv               1      4I 0 INZ(256)
     D  BytesAvl               5      8I 0 INZ(0)
     D  ErrMsgID               9     15
     D  Reserved              16     16
     D  ErrMsgDta             17    256

     DToUser           S             10a
     DToPassWord       S             10a
      *
     C     *Entry        Plist
     C                   Parm                    ToUser
     C                   Parm                    ToPassWord
      *
      * Retrieve the User Profile Handle
     c                   eval      RC = RtvProfile(ToUser:ToPassWord)
     c                   If        RC <> 0
      * Now Set the Job Profile to a NEW User Profile
     c                   eval      RC = SetUProf(handle)
     C                   Endif
     C                   Eval      *Inlr = *On

      *===============================================================
      *  Get User Profile Handle SubProcedure
      *===============================================================
     P RtvProfile      B
     D RtvProfile      PI            10I 0
     D   userid                      10A   Value
     D   password                    10A   Value


     c                   Eval      UserID = %Xlate(LC:UC:UserID)
     c                   Eval      Password = %Xlate(LC:UC:Password)

     c                   callp     GetProfile(UserID: Password: handle: ErrDS)
     c                   if        BytesAvl > 0
     c                   return    0
     C                   Else
     c                   return    1
     c                   endif

     P                 E

      *===============================================================
      *  Set User Profile To New User Profile SubProcedure
      *===============================================================
     P SetUProf        B
     D SetUProf        PI            10I 0
     D   HandleIn                    12A   Value

     c                   callp     SetProfile(handleIn: ErrDs)
     c                   if        BytesAvl > 0
     c                   return    0
     C                   Else
     c                   return    1
     c                   endif

     P                 E