From:	SMTP%"mailserv-reply@kopc.hhs.dk"  3-JAN-1994 09:30:51.79
To:	EVERHART
CC:	
Subj:	[MISC]EXTGETDDIR.MAR;1

Date: Mon, 03 Jan 1994 14:41:53 +0100
From: "PMDF Mailserv V4.2" <mailserv-reply@kopc.hhs.dk>
Subject: [MISC]EXTGETDDIR.MAR;1
To: EVERHART@arisia.gce.com
Message-id: <01H78ZRFGVEM8ZDZ76@kopc.hhs.dk>
MIME-version: 1.0
Content-type: TEXT/PLAIN
Content-transfer-encoding: 8BIT

        .title  extgetddir
;
;  Author     : Arne Vajhøj
;
;  Programmed : april 1993 by Arne Vajhøj
;
;  Purpose    : get default directory for another process
;
        .library "sys$library:lib"
        .link   "sys$system:sys.stb"/selective_search
        $SFDEF
        $IPLDEF
        $ACBDEF
        $DYNDEF
        $PCBDEF
        $PRIDEF
        $PSLDEF
        $SSDEF
EFN=17
        .psect  EXTGETDDIR quad,pic,con,lcl,noshr,exe,wrt
pid:    .blkl   1
prcnam: .blkl   1
ddir:   .blkb   4+256
;
;  Entry : EXTGETDDIR ( PID, PRCNAM , RESSTR , RESLEN )
;
;  Functionality : Get default directory in the context of another process.
;
;
;  Arguments : PID
;              pid of target process
;              longword passed by reference
;              readonly
;
;              PRCNAM
;              process name of target process
;              fixed length chracter string passed by descriptor
;              readonly
;
;              RESSTR
;              resultant string
;              fixed length chracter string passed by descriptor
;              writeonly
;
;              RESLEN
;              resultant string length
;              longword passed by reference
;              writeonly
;
;  Priviliges required : CMKRNL    to enter kernel mode
;                        WORLD     to translate from pid/prcnam to pcb for
;                                  an arbitrary process
;
;  Return codes : SS$_NORMAL        succesfull
;                 SS$_NOPRIV        no CMKRNL privilige present
;                 SS$_NONEXPR       no such process
;                 SS$_REMOTE_PROC   process not on this node in
;                                   cluster
;
;  Disclaimer : This is a kernel-mode-hack using several undocumented
;               features of VMS. I truly believe, that it will work
;               on any VMS 5.x system, but you use this code entirely at
;               your own risk.
;
;  Bugs : Please mail bug-reports to ARNE@KO.HHS.DK (Arne Vajhøj).
;
        .entry  extgetddir,^m<r2,r3,r4,r5>
        pushab  qkast_end
        pushab  qkast_start
        pushl   #0
        pushl   #0
        pushab  8(sp)
        calls   #3,G^SYS$LKWSET         ; lock pages in working-set
        blbc    r0,100$
;
        movl    4(ap),pid
        movl    8(ap),prcnam
;
        pushl   #0
        pushab  qkast
        calls   #2,G^SYS$CMKRNL         ; call qkast in kernel mode
        blbc    r0,100$
;
        pushl   #EFN
        calls   #1,G^SYS$WAITFR         ; wait for eventflag to be set
;
        movl    ddir,@16(ap)
        movl    12(ap),r1
        movc3   ddir,ddir+4,@4(r1)
        movl    #SS$_NORMAL,r0
;
100$:   ret
qkast_start:
        .entry  qkast,^m<r2,r3,r4,r5>
        movab   G^EXE$SIGTORET,SF$A_HANDLER(fp) ; set exception handler
        movl    r4,pcb                  ; save pcb
        movab   ddir,adr                ; save address
        pushl   prcnam
        pushl   pid
        pushl   #2
        movl    sp,ap
        jsb     G^EXE$NAMPID            ; convert external->internal PID
        addl2   #12,sp
        blbs    r0,100$
        brw     err
100$:   UNLOCK  SCHED,newipl=#IPL$_ASTDEL
        cmpl    r1,G^SCH$GL_SWPPID      ; test if swapper
        bneq    200$
        movl    #SS$_NONEXPR,r0
        brw     err
200$:   addl3   #kast_size,#ACB$K_LENGTH,r1
        jsb     G^EXE$ALONONPAGED       ; allocate ACB
        blbs    r0,300$
        brw     err
300$:   movw    r1,ACB$W_SIZE(r2)       ; fill ACB fields
        movb    #DYN$C_ACB,ACB$B_TYPE(r2)
        movb    #ACB$M_KAST!PSL$C_KERNEL,ACB$B_RMOD(r2)
        movl    PCB$L_PID(r4),ACB$L_PID(r2)
        movab   ACB$K_LENGTH(r2),ACB$L_KAST(r2)
        pushl   r2
        movc3   #kast_size,kast_code,ACB$K_LENGTH(r2) ; move AST code
        popl    r2
        pushr   #^m<r2,r4>
        movl    #EFN,r3
        movl    pcb,r4
        jsb     G^SCH$CLREF             ; clear event-flag
        popr    #^m<r2,r4>
        movl    r2,r5
        movl    #PRI$_TICOM,r2
        jsb     G^SCH$QAST              ; queue AST
        SETIPL  #0                      ; reset IPL
        movl    #SS$_NORMAL,r0          ; ok
        ret                             ; return
err:    SETIPL  #0                      ; reset IPL
        ret                             ; return
kast_code:
        pushr   #^m<r5>
        cvtbl   G^PIO$GT_DDSTRING,outbuf
        movc3   outbuf,G^PIO$GT_DDSTRING+1,outbuf+4
        popr    #^m<r5>
;
        movl    pcb,r4
        movl    PCB$L_PID(r4),ACB$L_PID(r5)
        addl2   #kast_code_size,ACB$L_KAST(r5)
        movb    #ACB$M_KAST!PSL$C_KERNEL,ACB$B_RMOD(r5)
        movl    #0,r2
        jmp     G^SCH$QAST              ; requeue AST
;
kast_code_size=.-kast_code
kast_code_2:
        pushr   #^m<r4,r5>
        movl    adr,r1
        movl    outbuf,(r1)
        movc3   outbuf,outbuf+4,4(r1)   ; save default directory information
        popr    #^m<r4,r5>
;
        movl    PCB$L_PID(r4),r1
        movl    #0,r2
        movl    #EFN,r3
        jsb     G^SCH$POSTEF            ; set event-flag
        movl    r5,r0
        jmp     G^EXE$DEANONPAGED       ; deallocate ACB and disappear
;
pcb:    .blkl   1
adr:    .blkl   1
outbuf: .blkb   4+256
kast_size=.-kast_code
qkast_end:
        .end