Trailing-Edge
-
PDP-10 Archives
-
BB-JF18A-BM
-
sources/diu/diupc2.b36
There are 4 other files named diupc2.b36 in the archive. Click here to see a list.
%TITLE 'DIU Controller IPCF routines'
MODULE DIUPC2 (IDENT = '257',
LANGUAGE(BLISS36),
ENTRY(
ipc_master, ! Declare ourself as IPCF master
ipc_hndlr ! IPCF interrupt handler
)
)=
BEGIN
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
! ALL RIGHTS RESERVED.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND
! COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
! THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR
! ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
! AVAILABLE TO ANY OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE
! SOFTWARE IS HEREBY TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
! NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
! EQUIPMENT CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF
! ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!
! FACILITY: DIU (Data Interchange Utility for TOPS-20)
!
!
! ABSTRACT: This module provides the IPCF (Interprocess
! Communication Facility) routines required by
! the DIU Controlling Job.
!
! ENVIRONMENT: TOPS-20 V6.1 RMS V3
! BLISS-36 V4 XPORT
! HISTORY:
!
! 257 Change library BLI:MONSYM to just MONSYM.
! Gregory A. Scott 7-Jul-86
!
! 253 Change IPCF20 library to DIUIP2.
! Gregory A. Scott 1-Jul-86
!
! 252 Remove library of CONDIT.
! Sandy Clemens 1-Jul-86
!
! 165 Use page 276 for ipcf page to avoid race problem with doing commands
! from the spooler job.
! Gregory A. Scott 16-May-86
!
! 164 Clean up ipc_master.
! Gregory A. Scott 16-May-86
!
! 156 Modify the dependent field of the incore copy of the request block when
! a request is entered with a prerequisite switch.
! Gregory A. Scott 13-May-86
!
! 154 Rename s$death to j$death and kill_job to j$kill. Add XPN conditions
! XPN$_DEVOFFLINE and XPN$_THIRD to requeueable errors.
! Gregory A. Scott 12-May-86
!
! 152 Check access to log file (if any) in IPC_ENTER. Write the "request
! created" message to both user and system log files from here, now that
! we know that access to the user log file has been checked.
! Gregory A. Scott 11-May-86
!
! 147 If a request being cancelled has a prerequisite then the prerequisite's
! dependent id wasn't being killed; solution is to call the fine
! IPC_MPREREQ routine from IPC_DELETE. Clean up Q$GIVEUP and rename it
! to be IPC_GIVEUP.
! Gregory A. Scott 8-May-86
!
! 146 Major changes to IPC_MPREREQ, including making it callable from
! IPC_ENTER, check for illegal modification of the prerequisite request
! number. Add error messages DIU$_PREREQ_NOT_YOURS and
! DIU$_PREREQ_NON_EXIST.
! Gregory A. Scott 7-May-86
!
! 135 Routines IPC_CONNECT_ME and Q$GIVEUP shouldn't be global, and they
! aren't anymore.
! Gregory A. Scott 1-May-86
!
! 127 Routine ipc_msequence is now ipc_mprereq, and it deals with changing
! the prerequisite id with no funny negation hacks included. Fix
! Q$GIVEUP so that it will return a value. Change module name to match
! filename (DIUPC2).
! Gregory A. Scott 26-Apr-86
!
! 126 Routines IPC_CONNECT_ME and IPC_STATUS shouldn't try and return a
! value.
! Gregory A. Scott 26-Apr-86
!
! 122 Make sure that the location that would point to a byte pointer for the
! sender's node name is 0 in routine ipc_hndlr or we will get an
! occasional unexpected string from the monitor.
! Gregory A. Scott 22-Apr-86
!
! 52 Make sure PDB size is large enough so that the account string can
! be retrieved in routine IPC_HNDLR. Update IPC_HANDLER and IP_ENTER
! routines with missing edit from FTS which enables use of account
! string.
! Sandy Clemens 12-Nov-85
!
! 43 Clean up the Q$GIVEUP routine.
! Sandy Clemens 16-Oct-85
!
! 05 - (AN) Put the sender's account in the request block when we receive it.
! 04 - Look before trying to read IPCF message
! 03 - Requeue on file-locked
! 02 - Put in ENTRY points
! 01 - beginning
!--
! TABLE OF CONTENTS:
FORWARD ROUTINE
ipc_prvchk, ! Check caller's privileges
ipc_hndlr : NOVALUE, ! IPCF interrupt handler
ipc_handle : NOVALUE, ! Handle one IPCF message
ipc_giveup, ! Decide if we should reque or discard
ipc_master, ! Declare ourself as IPCF master
ipc_enter : NOVALUE, ! Handle received enter request
ipc_delete : NOVALUE, ! Handle received delete request
ab_delete, ! Condition handler for above
ipc_find : NOVALUE, ! Handle received find request
ipc_modify : NOVALUE, ! Handle received modify request
ipc_mprereq, ! Modify /PREREQUISITE chain
ipc_status : NOVALUE, ! Handle received status request
ipc_connect_me : NOVALUE; ! Handle "connect me" request
! LIBRARIES:
LIBRARY 'MONSYM'; ! TOPS-20 Monitor symbols
LIBRARY 'BLI:XPORT';
LIBRARY 'DIU';
LIBRARY 'BLISSNET';
LIBRARY 'RMSINT';
LIBRARY 'DIUIP2';
! External references
BIND ip_page = %O'276000' : BLOCK [512] FIELD (DIUQ$$MESSAGE_FIELDS);
EXTERNAL rcvpid, ! PID master receives queries on
jobstatus : BLOCKVECTOR [DIU$K_MAX_MJOB, DIUJ$K_LEN]
FIELD (DIUJ$$JOBSTAT_FIELDS);
EXTERNAL ROUTINE
ip$send, ! Send an IPCF message
ip$receive, ! Receive an IPCF message
ip$declare, ! Declare name/PID association
ip$qtest, ! Test emptiness of IPCF receive queue
lj$event : NOVALUE, ! Log a event in system log file
l$event : NOVALUE, ! Log a event in system log file
l$uevent : NOVALUE, ! Log event about slave in sys log file
l$new_request : NOVALUE, ! Log a new request
l$check_access, ! Check access to log file
diu$errmsg : NOVALUE, ! Expand (don't type) error code
diu$abort : NOVALUE, ! Condition handler
sched : NOVALUE, ! Scheduler routine
j$kill, ! Kill a slave job
abort : NOVALUE, ! Abort dependent requests
notify : NOVALUE, ! Notify requestor of job disposition
j$death : NOVALUE, ! Process slave job death report
s$username, ! Translate user no. to name string
s$jobno, ! Get our job number
s$dirno, ! Convert string to directory number
s$connect, ! Connect a job to a directory
s$time, ! Return current date/time
s$dtstr : NOVALUE, ! Convert date/time to string
q$copy_req_block : NOVALUE, ! Copy a request block
q$release_chain : NOVALUE, ! Release chain of request blocks
q$req_block_init : NOVALUE, ! Zap a request block
q$valid_req_block, ! Validate a request block
q$enter, ! Enter a request in the queue
q$delete, ! Delete a request from the queue
q$find, ! Find one or more requests
q$modify, ! Modify a request
moveaz; ! Move ASCIZ string
GLOBAL ROUTINE ipc_master (p_name_desc, p_pid) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Declare ourself as a system process.
!
! FORMAL PARAMETERS:
!
! p_name_desc: pointer to descriptor for name string
! p_pid: pointer to PID to associate with name, if that location is zero
! assign a new pid.
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL: success
! DIU$_TWO_MASTERS: another one already declared
! DIU$_BUG: unexpected error
!
!--
BEGIN
BIND name = .p_name_desc,
pid = .p_pid;
LOCAL retcode;
retcode = ip$declare (name, pid);
IF NOT .retcode
THEN BEGIN
SELECTONE (.retcode ^ -18) OF
SET
[$IPCPI, $IPCEN, IPCF11, IPCF13] : SIGNAL (DIU$_INSUFF_PRIVS);
[$IPCDN] : SIGNAL (DIU$_TWO_MASTERS);
[OTHERWISE] : SIGNAL (DIU$_BUG, .retcode ^ -18);
TES
END
ELSE RETURN (DIU$_NORMAL)
END; ! End of ipc_master
ROUTINE ipc_prvchk (p_pdb, p_req_block) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Check to make sure an IPCF caller is privileged to hack a request.
!
! FORMAL PARAMETERS:
!
! p_pdb: pointer to Packet Data Block for IPCF message
! p_req_block - pointer to request block
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! FALSE: not caller's request and no privs, don't allow it
! TRUE: OK, caller's request, or caller is godly
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL,
req_block = .p_req_block : $DIU_BLOCK;
! First, if caller is WHEEL or OPERATOR, allow anything
IF .pdb[PDB$$V_WHEEL] OR .pdb[PDB$$V_OPERATOR]
THEN RETURN (TRUE);
! Not privileged, must sniff at request block and see if usernumber
! of request originator is same as usernumber of message sender
IF .pdb[PDB$$G_SENDER_USER_NUMBER]
NEQ .req_block[DIU$G_USER_NUMBER]
THEN RETURN (FALSE)
ELSE RETURN (TRUE)
END; ! End of ipc_prvchk
GLOBAL ROUTINE ipc_hndlr : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! IPCF message receipt interrupt handler. This routine repeatedly pulls
! messages from the IPCF input queue and dispatches to handler routines
! based on the function code in each message. It establishes a condition
! handler (the default one) so that an unwind will terminate this
! routine, and not some other one, so that we return to the interrupt
! handler and DEBRK. The handler routine in turn establishes a condition
! handler (again the default one) so that errors in processing any one
! request return to the top loop here, rather than DEBRKing, which would
! cause IPCF messages to be lost.
!
!--
BEGIN
LOCAL retcode,
ipcode,
accountstring: VECTOR[ CH$ALLOCATION(40) ],
pdb : $$PDB_DECL;
ENABLE DIU$ABORT;
pdb[PDB$$A_SENDER_NODE_NAME] = 0; ! Zero this for compatibility
WHILE ip$qtest (.rcvpid) ![4] Look before we try to read
DO BEGIN
pdb[PDB$$A_SENDER_ACCOUNT]=CH$PTR(accountstring); ! We want the account
pdb[PDB$$H_MESSAGE_ADDRESS] = ip_page;
pdb[PDB$$H_MESSAGE_LENGTH] = 512;
ipcode = ip$receive (rcvpid, pdb, $IPCLL + 1);
! Quit immediately if failure
IF NOT .ipcode
THEN RETURN;
! Go handle this message and loop back for more
ipc_handle (pdb, CH$PTR (accountstring));
END;
END; ! End of ipc_hndlr
ROUTINE ipc_handle (p_pdb, accountpointer) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Process one incoming IPCF message. We ENABLE the default condition
! handler so that an error (which will unwind) returns to the IPCF
! message eating loop.
!
! FORMAL PARAMETERS:
! p_pdb: pointer to the PDB for the message
! accountpointer: pointer to account string
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL;
ENABLE DIU$ABORT;
! Dispatch on function code. First see if this message
! is from the monitor, reporting the death of a subjob.
IF .ip_page EQL $IPCLO
THEN j$death (pdb)
! Not from monitor, must be from an DIU job.
ELSE SELECTONE .ip_page[DIUQ$B_FUNCTION] OF
SET
[DIUQ$K_ENTER] : ipc_enter (pdb, .accountpointer);
[DIUQ$K_DELETE] : ipc_delete (pdb);
[DIUQ$K_FIND] : ipc_find (pdb);
[DIUQ$K_MODIFY] : ipc_modify (pdb);
[DIUQ$K_STATUS] : ipc_status (pdb);
[DIUQ$K_CONNECT_ME] : ipc_connect_me (pdb);
[OTHERWISE] : SIGNAL (DIU$_INV_IPCF_MSG);
TES;
END; ! End of ipc_handle
ROUTINE ipc_enter (p_pdb, accountpointer) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Handle an IPCF message to ENTER a request in the queue.
!
! FORMAL PARAMETERS:
!
! p_pdb: pointer to PDB (Packet Descriptor Block)
! accountpointer: pointer to account string
!
! IMPLICIT INPUTS:
!
! The PDB points to the message.
!
! SIDE EFFECTS:
!
! An IPCF message is sent to the originator of the request informing
! it of the success or failure of the request. In addition, if the
! enter succeeded, the scheduler is called to try to start the request.
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL,
req_block = ip_page[DIUQ$Z_REQ_BLOCK] : $DIU_BLOCK;
LOCAL user_descriptor : $STR_DESCRIPTOR (),
connected_descriptor : $STR_DESCRIPTOR (),
retcode;
! Make some cursory validity checks on the request block
req_block[DIU$V_ACTIVE] = 0;
IF .req_block[DIU$B_PRIORITY] GTR 63
THEN retcode = DIU$_INVALID_PRIORITY
ELSE retcode = q$valid_req_block (req_block);
IF NOT .retcode
THEN BEGIN
ip_page[DIUQ$G_COMP_CODE] = .retcode;
ip_page[DIUQ$B_FUNCTION] = DIUQ$K_NACK;
ip$send (.pdb[PDB$$G_SENDER_PID], rcvpid, ip_page, 512);
RETURN;
END;
! Get user number from packet data block. Store it and the corresponding
! username string in the request block. Insure username is ASCIZ.
req_block[DIU$G_USER_NUMBER] = .pdb[PDB$$G_SENDER_USER_NUMBER];
$STR_DESC_INIT (DESCRIPTOR = user_descriptor,
STRING = (RMS$K_USERID_SIZE,
CH$PTR (req_block[DIU$T_USERNAME])));
req_block[DIU$H_USERNAME] =
s$username (.pdb[PDB$$G_SENDER_USER_NUMBER], user_descriptor);
! Get connected directory number and enabled capabilities from packet
! and store in req block.
req_block[DIU$G_CAPABILITIES] = .pdb[PDB$$V_SENDER_CAPABILITIES];
$STR_DESC_INIT (DESCRIPTOR = connected_descriptor,
STRING = (DIU$K_TOPS20_DIRECTORY_SIZE,
CH$PTR (req_block[DIU$T_CONNECTED_DIRECTORY])));
req_block[DIU$H_CONNECTED_DIRECTORY] =
s$username (.pdb[PDB$$G_SENDER_DIRECTORY],
connected_descriptor);
! Put the account string and it's length in the request block
req_block[DIU$H_ACCOUNT] = ! store length of the account string
moveaz (%REF(.accountpointer), ! non-updated pointer
%REF(CH$PTR(req_block[DIU$T_ACCOUNT]))); ! updated by Moveaz
! Supply creation date-time
req_block[DIU$G_CREATION] = s$time ();
! See if user can write to the log file specified, if one was specifed.
IF .req_block[DIU$H_LOG_FILESPEC] NEQ 0
THEN retcode = L$CHECK_ACCESS(.pdb[PDB$$G_SENDER_USER_NUMBER], ! Check access
.pdb[PDB$$G_SENDER_DIRECTORY], ! to the log
.pdb[PDB$$V_SENDER_CAPABILITIES], ! file if any
req_block[DIU$T_LOG_FILESPEC]) ! specified
ELSE retcode = TRUE; ! Success if no log file
! Enter the request and log it if successful
IF .retcode ! If we are OK so far
THEN IF (retcode = q$enter (req_block)) ! then try and enter the request
THEN BEGIN
LOCAL new_req_line : $STR_DESCRIPTOR (CLASS = DYNAMIC);
$STR_DESC_INIT (DESCRIPTOR = new_req_line, CLASS = DYNAMIC);
l$new_request (req_block, new_req_line); ! ASCIIze the request
l$event(DIU$_REQ_CREATED,0,new_req_line); ! Log to system log
l$uevent(DIU$_REQ_CREATED,0,new_req_line,req_block); ! Log to user
$XPO_FREE_MEM (STRING = new_req_line); ! Thanks for the memory
END;
! If there is a prerequisiste specified, call someone to set it up. If
! something went wrong, delete the request from the queue. If the modify
! forked, then we want to check for an incore copy of the request and modify it
! so that the prerequisite request number matches the on disk copy.
IF .retcode AND .req_block[DIU$H_PREREQUISITE_ID] NEQ 0
THEN BEGIN
IF NOT (retcode = ipc_mprereq (pdb, ! pdb
0, ! old
.req_block[DIU$H_PREREQUISITE_ID], ! new
.req_block[DIU$H_REQUEST_ID])) ! req
THEN q$delete (.req_block[DIU$H_REQUEST_ID])
ELSE BEGIN ! modify worked, check incore copy
INCR job_handle FROM 0 TO DIU$K_MAX_MJOB - 1
DO IF (.jobstatus[.job_handle, DIUJ$H_REQUEST_ID]
EQL .req_block[DIU$H_PREREQUISITE_ID])
AND .jobstatus[.job_handle, DIUJ$V_INUSE]
THEN BEGIN ! Incore copy, set its dependent req
BIND dep_blk = .jobstatus[.job_handle,
DIUJ$A_REQ_BLOCK] : $DIU_BLOCK;
dep_blk[DIU$H_DEPENDENT_ID] =
.req_block[DIU$H_REQUEST_ID];
END;
END;
END;
! Now respond with a success or failure message, as appropriate
IF NOT .retcode
THEN BEGIN
ip_page[DIUQ$G_COMP_CODE] = .retcode;
ip_page[DIUQ$B_FUNCTION] = DIUQ$K_NACK
END
ELSE ip_page[DIUQ$B_FUNCTION] = DIUQ$K_ACK;
ip$send (.pdb[PDB$$G_SENDER_PID], rcvpid, ip_page, 512);
SCHED(); ! Try to start the request
END; ! End of ipc_enter
ROUTINE ipc_delete (p_pdb) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Handle an IPCF message to DELETE a request in the queue. Note that
! this routine ALWAYS signals and NEVER returns. This turns out to be a
! more convenient way of insuring that all the dynamic storage it
! allocates gets deallocated. Our condition handler simply releases
! storage, reports the condition code to the sender of the delete
! request, and unwinds.
!
! FORMAL PARAMETERS:
!
! p_pdb: pointer to PDB (Packet Descriptor Block)
!
! SIDE EFFECTS:
!
! The request is deleted from the queue. A notification message is sent
! to the originator of the request informing him/her of the cancellation
! of the request.
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL;
LOCAL retcode,
usr_line : VECTOR[CH$ALLOCATION(80)],
usr_descr : $STR_DESCRIPTOR (CLASS = BOUNDED,
STRING = (80,CH$PTR(usr_line))),
log_line : VECTOR[CH$ALLOCATION(200)],
log_descr : $STR_DESCRIPTOR (CLASS = BOUNDED,
STRING = (200,CH$PTR(log_line))),
chain_head : VOLATILE,
tmp_blk_ptr : VOLATILE REF $DIU_BLOCK,
req_block : REF $DIU_BLOCK,
job_handle,
tpdb : VOLATILE;
ENABLE ab_delete (chain_head, tmp_blk_ptr, tpdb);
tpdb = pdb;
IF .ip_page[DIUQ$G_REQ_ID] LSS 2 ! If illegal request id,
THEN SIGNAL (DIU$_INVALID_REQUEST); ! then give a fatal error
! Allocate and init a template request block
IF NOT (retcode = $XPO_GET_MEM (UNITS = DIU$K_LEN,
RESULT = tmp_blk_ptr))
THEN SIGNAL (.retcode);
q$req_block_init (.tmp_blk_ptr);
tmp_blk_ptr[DIU$H_REQUEST_ID] = .ip_page[DIUQ$G_REQ_ID];
! Get the actual request block
IF NOT (retcode = q$find (.tmp_blk_ptr, chain_head))
THEN SIGNAL (.retcode);
req_block = .chain_head + 1;
! Check to make sure this guy is allowed to delete
IF NOT ipc_prvchk (pdb, .req_block)
THEN SIGNAL (DIU$_INSUFF_PRIVS);
! Get username of killer for log file
s$username (.pdb[PDB$$G_SENDER_USER_NUMBER], usr_descr);
! Construct a line of text to be sent to the system and user log files.
$STR_COPY(TARGET = log_descr,
STRING = $STR_CONCAT('Request ',
$STR_ASCII (.req_block[DIU$H_REQUEST_ID]),
' (',
(.req_block[DIU$H_JOBNAME],
CH$PTR(req_block[DIU$T_JOBNAME])),
') killed by user ',
usr_descr));
! If request is active, stomp on the corresponding slave job (dependent jobs
! will be killed by slave job cleanup code). If not active, must kill
! dependents now.
job_handle = -1; ! Set job_handle to "not found"
IF .req_block[DIU$V_ACTIVE] ! If the job was active, kill it
THEN job_handle = j$kill (.req_block[DIU$H_REQUEST_ID],
DIU$_KILLED_BY_USER);
IF .job_handle NEQ -1
THEN BEGIN ! If the job was active and we found it
jobstatus[.job_handle, DIUJ$V_ALREADY_DELETED] = 1;
$STR_COPY (TARGET = jobstatus[.job_handle, DIUJ$T_EXTRA_TEXT],
STRING = log_descr);
END
ELSE BEGIN ! The job wasn't active
l$event(DIU$_KILLED_BY_USER, 0, log_descr);
l$uevent(DIU$_KILLED_BY_USER, 0, log_descr, .req_block);
notify (DIU$_KILLED_BY_USER, 0, log_descr, .req_block);
IF .req_block[DIU$H_DEPENDENT_ID] NEQ 0
THEN abort (.req_block[DIU$H_DEPENDENT_ID]);
END;
! Clear any prerequisiste request's dependecy on this request
IF .req_block[DIU$H_PREREQUISITE_ID] NEQ 0 ! If request has prerequisite
THEN ipc_mprereq(pdb, ! clear it
.req_block[DIU$H_PREREQUISITE_ID], ! Old value
0, ! New value
.req_block[DIU$H_REQUEST_ID]); ! Req id
! Delete the request block from the queue.
retcode = q$delete (.req_block[DIU$H_REQUEST_ID]);
! Now respond with a success or failure message, as appropriate
SIGNAL (.retcode)
END; ! End of ipc_delete
ROUTINE ab_delete (sig, mech, enbl) =
!++
! FUNCTIONAL DESCRIPTION:
! Condition handler for ipc_delete. We first free up any dynamic
! storage we have lying around and then try to reply to the delete
! request via IPCF. We then unwind, which causes ipc_delete to return.
!
! FORMAL PARAMETERS:
! sig - signal vector
! mech - mechanism vector
! enbl - enable vector (see BLISS Language Guide for definitions
! of these)
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
MAP
sig : REF VECTOR,
mech : REF VECTOR,
enbl : REF VECTOR;
BIND
chain_head = .enbl[1],
tmp_blk_ptr = .enbl[2],
pdb = .enbl[3] : REF $$PDB_DECL,
retcode = sig[1];
IF .sig[1] EQL STS$K_UNWIND
THEN
RETURN (STS$K_NORMAL);
IF .chain_head NEQ 0
THEN
$XPO_FREE_MEM (BINARY_DATA = (DIU$K_LEN + %UPVAL,
.chain_head, UNITS));
IF .tmp_blk_ptr NEQ 0
THEN
$XPO_FREE_MEM (BINARY_DATA = (DIU$K_LEN, .tmp_blk_ptr, UNITS));
IF NOT .retcode
THEN
BEGIN
ip_page[DIUQ$G_COMP_CODE] = .retcode;
ip_page[DIUQ$B_FUNCTION] = DIUQ$K_NACK
END
ELSE
ip_page[DIUQ$B_FUNCTION] = DIUQ$K_ACK;
ip$send (.pdb[PDB$$G_SENDER_PID], rcvpid, ip_page, 512);
SETUNWIND ()
END; ! End of ab_delete
ROUTINE ipc_find (p_pdb) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
! Handle an IPCF message to FIND one or more requests in the queue.
!
! FORMAL PARAMETERS:
! p_pdb - pointer to PDB (Packet Descriptor Block)
!
! IMPLICIT INPUTS:
! The PDB points to the message.
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! Request blocks are returned to the sender, one per IPCF message,
! until all matching requests have been returned.
!
!--
BEGIN
BIND
pdb = .p_pdb : $$PDB_DECL,
req_block = ip_page[DIUQ$Z_REQ_BLOCK] : $DIU_BLOCK;
LOCAL
retcode,
chain_head,
current,
sequence_number;
retcode = q$find (req_block, chain_head);
!
! If q$find failed, return exactly one failure message.
!
IF NOT .retcode
THEN
BEGIN
ip_page[DIUQ$G_COMP_CODE] = .retcode;
ip_page[DIUQ$B_FUNCTION] = DIUQ$K_NACK;
ip$send (.pdb[PDB$$G_SENDER_PID], rcvpid, ip_page, 512);
RETURN;
END;
!
! q$find returned at least one request block. Send them all to the sender.
!
sequence_number = 1;
current = chain_head;
WHILE (current = ..current) NEQ 0
DO
BEGIN
BIND
this_request = .current + 1 : $DIU_BLOCK;
q$copy_req_block (this_request, req_block);
!
! Zero fields of interest to DIU master job only
!
req_block[DIU$H_NEXT_RECORD] = 0;
req_block[DIU$H_PREV_RECORD] = 0;
!
! If caller is neither privileged nor the owner of the request,
! zero sensitive fields.
!
IF NOT ipc_prvchk (pdb, req_block)
THEN
BEGIN
req_block[DIU$H_SOURCE_FILESPEC] = 0;
CH$FILL (0,
DIU$K_FILESPEC_MAXIMUM_LENGTH,
CH$PTR (req_block[DIU$T_SOURCE_FILESPEC]));
req_block[DIU$H_DESTINATION_FILESPEC] = 0;
CH$FILL (0,
DIU$K_FILESPEC_MAXIMUM_LENGTH,
CH$PTR (req_block[DIU$T_DESTINATION_FILESPEC]));
req_block[DIU$H_LOG_FILESPEC] = 0;
CH$FILL (0,
DIU$K_FILESPEC_MAXIMUM_LENGTH,
CH$PTR (req_block[DIU$T_LOG_FILESPEC]));
req_block[DIU$H_ACCOUNT] = 0;
CH$FILL (0, 40,
CH$PTR (req_block[DIU$T_ACCOUNT]));
req_block[DIU$H_TERMINAL] = 0;
req_block[DIU$H_JOB_NUMBER] = 0;
req_block[DIU$G_NOTIFY_PID] = 0;
req_block[DIU$G_CAPABILITIES] = 0;
END;
!
! If this is the last request, return DIU$_NORMAL. If more
! to come, return DIU$_MORE.
!
ip_page[DIUQ$G_COMP_CODE] =
(IF ..current NEQ 0 THEN DIU$_MORE ELSE DIU$_NORMAL);
ip_page[DIUQ$B_FUNCTION] = DIUQ$K_ACK;
ip_page[DIUQ$H_SEQUENCE_NUMBER] = .sequence_number;
ip$send (.pdb[PDB$$G_SENDER_PID], rcvpid, ip_page, 512);
sequence_number = .sequence_number + 1;
END;
q$release_chain (.chain_head);
END; ! End of ipc_find
ROUTINE ipc_modify (p_pdb) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Handle an IPCF message to MODIFY a request in the queue. This routine
! never explicitly returns, but instead SIGNALs its success or failure.
! The condition handler sends the completion code to the requestor and
! then unwinds. We use the same handler ipc_delete does.
!
! FORMAL PARAMETERS:
!
! p_pdb: pointer to PDB (Packet Descriptor Block)
!
! SIDE EFFECTS:
!
! An IPCF message is sent to the originator of the request informing it
! of the success or failure of the request. If the /AFTER parameter or
! /DEADLINE switch are diddled, we call the scheduler to update its
! knowledge.
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL,
message = ip_page : BLOCK [512] FIELD (DIUQ$$MESSAGE_FIELDS);
LOCAL retcode,
chain_head : VOLATILE,
tmp_blk_ptr : VOLATILE REF $DIU_BLOCK,
req_block : REF $DIU_BLOCK,
tpdb : VOLATILE;
ENABLE ab_delete (chain_head, tmp_blk_ptr, tpdb);
tpdb = pdb;
! Allocate and init a template request block
IF NOT (retcode = $XPO_GET_MEM (UNITS = DIU$K_LEN, RESULT = tmp_blk_ptr))
THEN SIGNAL (.retcode);
q$req_block_init (.tmp_blk_ptr);
tmp_blk_ptr[DIU$H_REQUEST_ID] = .ip_page[DIUQ$G_REQ_ID];
! Get the actual request block
IF NOT (retcode = q$find (.tmp_blk_ptr, chain_head))
THEN SIGNAL (.retcode);
req_block = .chain_head + 1;
! Check to make sure this guy is allowed to hack this request
IF NOT ipc_prvchk (pdb, .req_block)
THEN SIGNAL (DIU$_INSUFF_PRIVS);
! Make sure it isn't active now
IF .req_block[DIU$V_ACTIVE]
THEN SIGNAL (DIU$_ACTIVE);
! Some items are easier to modify than others. Do the work now.
SELECTONE .message[DIUQ$B_ITEM_CODE] OF
SET
[DIUQ$K_LOG_FILESPEC] : ! /LOG or /NOLOG
BEGIN
! If we're being asked to modify the log filespec, we must cons up
! a descriptor that points to the new filespec and pass that to
! q$modify
LOCAL log_descr : $STR_DESCRIPTOR ();
$STR_DESC_INIT (DESCRIPTOR = log_descr, CLASS = FIXED,
STRING = (.message[DIUQ$H_STATUS_TEXT],
CH$PTR (message[DIUQ$T_STATUS_TEXT])));
retcode = q$modify (.message[DIUQ$G_REQ_ID],
.message[DIUQ$B_ITEM_CODE],
log_descr)
END;
[DIUQ$K_PREREQUISITE_ID] : ! /PREREQ
retcode = ipc_mprereq (pdb,
.req_block[DIU$H_PREREQUISITE_ID], ! old value
.message[DIUQ$G_NEW_VALUE], ! new value
.message[DIUQ$G_REQ_ID]); ! req id
[OTHERWISE] : ! /AFTER /DEAD /NOTIFY /PRIO /SEQU
BEGIN
! This is the simple case, where the new value is just a number
! Range check priority argument, gods get greater priority
IF .message[DIUQ$B_ITEM_CODE] EQL DIUQ$K_PRIORITY
THEN message[DIUQ$G_NEW_VALUE] =
MIN (.message[DIUQ$G_NEW_VALUE],
63+(.pdb[PDB$$V_WHEEL] OR .pdb[PDB$$V_OPERATOR]));
! Modify the request
retcode = q$modify (.message[DIUQ$G_REQ_ID],
.message[DIUQ$B_ITEM_CODE],
.message[DIUQ$G_NEW_VALUE]);
! If /AFTER or /DEADLINE or HOLD diddled OK, poke scheduler
IF .retcode ! If the modify succeeded
AND ((.message[DIUQ$B_ITEM_CODE] EQL DIUQ$K_AFTER)
OR (.message[DIUQ$B_ITEM_CODE] EQL DIUQ$K_DEADLINE)
OR (.message[DIUQ$B_ITEM_CODE] EQL DIUQ$K_HOLDING))
THEN SCHED(); ! Time to call scheduler
END;
TES;
! Now respond with a success or failure message, as appropriate
SIGNAL (.retcode)
END; ! End of ipc_modify
ROUTINE ipc_mprereq (p_pdb, old_value, new_value, req_id) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Modify the /PREREQ attributes of a request: either create a new
! dependency or remove an old one.
!
! FORMAL PARAMETERS:
!
! p_pdb: pdb to pass to ipc_prvchk
! p_old_value: existing prereqisite id field
! p_new_value: prereqisite id to change to
! p_req_id: request to modify
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! DIU$_NORMAL: for success
! errors: error codes
!
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL;
LOCAL retcode,
chain_head,
peek_req,
prereq_blk : REF $DIU_BLOCK,
tmp_prereq_blk : $DIU_BLOCK;
! Check to see if we're adding a new dependency or removing one
IF .new_value NEQ 0
THEN BEGIN ! Adding a new dependency
! Make sure that we aren't setting the prereq to ourselves
IF .new_value EQL .req_id
THEN RETURN(DIU$_PREREQ_LOOP); ! Loop detected
! If a prerequisite already exists, we must clear its dependency field
! We can sleaze this out by recursing with a zero prerequisite arg.
IF .old_value NEQ 0 ! If there was a prereq already
THEN BEGIN ! then zero it now
IF NOT (retcode = ipc_mprereq (pdb, .old_value, 0, .req_id))
THEN RETURN (.retcode);
END;
! Look through the chain of requests to see that we aren't creating
! a loop (deadly embrace) and that we have ownership to all of the
! requests specified.
peek_req = .new_value; ! Set the peek request to start
WHILE .peek_req NEQ 0 ! Loop until all have been checked
DO BEGIN
! Look up the prerequisite request
q$req_block_init (tmp_prereq_blk);
tmp_prereq_blk[DIU$H_REQUEST_ID] = .peek_req;
IF NOT q$find (tmp_prereq_blk, chain_head)
THEN RETURN (DIU$_PREREQ_NON_EXIST); ! Prereq does not exist
prereq_blk = .chain_head + %UPVAL;
! Make sure we're allowed to hack the prerequisite request
IF NOT ipc_prvchk (pdb, .prereq_blk)
THEN RETURN (DIU$_PREREQ_NOT_YOURS); ! Protection failure
! Check for deadly embrace of requests (loop of requests)
IF .prereq_blk[DIU$H_REQUEST_ID] EQL .req_id
THEN RETURN (DIU$_PREREQ_LOOP);
! sanity check this request if it is the immediate prereq
IF .prereq_blk[DIU$H_DEPENDENT_ID] NEQ 0
AND .peek_req EQL .new_value
THEN RETURN (DIU$_HAS_DEPENDENT);
! OK so far, set the next request to peek at from the prereq of this
peek_req = .prereq_blk[DIU$H_PREREQUISITE_ID];
! Release req block we are peeking at and loop for more requests
q$release_chain (.chain_head);
END; ! End of WHILE .peek_req NEQ 0 DO loop
! No deadly embrace, modify dependent field of prerequisite to point to us
retcode = q$modify (.new_value, ! Request to work on
DIUQ$K_DEPENDENT_ID,
.req_id);
! If that won, modify this request to have a prerequisite
IF .retcode
THEN retcode = q$modify (.req_id, ! Request to work on
DIUQ$K_PREREQUISITE_ID,
.new_value);
END
ELSE BEGIN ! Removing a dependency
IF .old_value EQL 0 ! Was there a dependency?
THEN RETURN (DIU$_NO_PREREQ);
! Look up the prerequisite request
q$req_block_init (tmp_prereq_blk);
tmp_prereq_blk[DIU$H_REQUEST_ID] = .old_value;
IF NOT q$find (tmp_prereq_blk, chain_head)
THEN RETURN (DIU$_PREREQ_NON_EXIST); ! Prereq does not exist
prereq_blk = .chain_head + %UPVAL;
! See if we can hack this request
IF NOT ipc_prvchk (pdb, .prereq_blk)
THEN RETURN (DIU$_PREREQ_NOT_YOURS); ! Protection failure
! Sanity check this request
IF .prereq_blk[DIU$H_DEPENDENT_ID] EQL 0
THEN RETURN (DIU$_INVALID_PREREQ); ! If we get here the queue is mangled
! Release storage associated with the request we are peeking at
q$release_chain (.chain_head);
! OK, zero dependent field of prerequisite
retcode = q$modify (.old_value, ! Request to work on
DIUQ$K_DEPENDENT_ID,
0);
! If that won, modify this request to have no prerequisite
IF .retcode
THEN retcode = q$modify (.req_id, ! Request to work on
DIUQ$K_PREREQUISITE_ID,
0);
END;
! Return the code we generated here, whatever that is
RETURN (.retcode)
END; ! ipc_mprereq
ROUTINE ipc_status (p_pdb) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Handle an IPCF message that reports STATUS of a transfer. These
! messages are generated by slave jobs either in response to error
! conditions or to report checkpoints.
!
! FORMAL PARAMETERS:
!
! p_pdb: pointer to PDB (Packet Descriptor Block)
!
! IMPLICIT INPUTS:
!
! The PDB points to the message.
!
! IMPLICIT OUTPUTS:
!
! The job status block for this job is updated with the codes passed.
!
! SIDE EFFECTS:
!
! An entry is made to the system log file.
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL,
message = ip_page : BLOCK [512] FIELD (DIUQ$$MESSAGE_FIELDS);
LOCAL retcode,
retcode_2ndary,
job,
job_handle,
msg_descr : $STR_DESCRIPTOR (CLASS = DYNAMIC),
msg_length,
opt_descr : $STR_DESCRIPTOR (),
req_block : REF $DIU_BLOCK,
notify_pid;
job = .message[DIUQ$H_SENDER_JOB]; ! Set passed job number
job_handle = .message[DIUQ$G_JOB_HANDLE]; ! Set passed job handle
retcode = .message[DIUQ$G_COMP_CODE]; ! Set primary code
retcode_2ndary = .message[DIUQ$G_2ND_CODE]; ! Set secondary code
! Find the job status block for this slave.
IF .job NEQ .jobstatus[.job_handle, DIUJ$H_JOB_NUMBER]
THEN BEGIN
SIGNAL (DIU$_UNSOLICITED_STATUS);
RETURN;
END;
req_block = .jobstatus[.job_handle, DIUJ$A_REQ_BLOCK];
! Make a string descriptor for additonal text (if any).
$STR_DESC_INIT (DESCRIPTOR = opt_descr, CLASS = FIXED,
STRING = (.message[DIUQ$H_STATUS_TEXT],
CH$PTR (message[DIUQ$T_STATUS_TEXT])));
! Write this event to system log file
lj$event(.retcode, .retcode_2ndary, opt_descr, .job_handle);
! Copy condition codes to the job status block. If optional text supplied,
! copy it to job status block for NOTIFY's purposes
IF .opt_descr[STR$H_LENGTH] NEQ 0
THEN $STR_COPY (TARGET = jobstatus[.job_handle, DIUJ$T_EXTRA_TEXT],
STRING = opt_descr);
jobstatus[.job_handle, DIUJ$G_LAST_ERROR] = .retcode;
jobstatus[.job_handle, DIUJ$G_2ND_CODE] = .retcode_2ndary;
! Update job status bits according to the status msg we got
SELECTONE (.retcode) OF
SET
[DIU$_REQUEST_COMPLETED] : jobstatus[.job_handle,
DIUJ$V_REQ_COMPLETED] = 1;
[DIU$_REQUEST_STARTED] : jobstatus[.job_handle,
DIUJ$V_SIGNED_ON] = 1;
TES;
! Decide weather to give up now or requeue or what
IF ipc_giveup(.retcode,.retcode_2ndary)
THEN jobstatus[.job_handle, DIUJ$V_FLUSH_REQUEST] = 1;
! If caller was DIULIB and wanted IPCF notifications, send one
! Don;t forget to supply user context word for caller's edification
IF (notify_pid = .req_block[DIU$G_NOTIFY_PID]) NEQ 0
THEN BEGIN
message[DIUQ$G_CTX] = .req_block[DIU$G_CTX];
ip$send (.notify_pid, rcvpid, ip_page, 512);
END;
END; ! End of ipc_status
ROUTINE ipc_giveup (statuscode, statuscode_2ndary) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Make the decision to (re)queue a request depending on the return code.
! Almost all failure codes cause us to flush the request. Unfortunately,
! RMS-20 error codes don't follow BLISS success/fail conventions, so we
! have to treat them separately by translating into codes which do follow
! the conventions. In addition, RMS$_DCF (DECNET connect failure) and
! RMS$_DCB (DECNET connection broken) errors don't tell us anything so we
! have to examine the secondary code, which has the useful information
! for controlling requeuing/flushing of jobs.
!
! FORMAL PARAMETERS:
!
! statuscode: primary status code
! statuscode_2ndary: secondary status code (or zero)
!
! ROUTINE VALUE:
!
! FALSE = don't give up the request (requeue it)
! TRUE = give up (don't requeue it)
!--
MACRO requeue_codes = ! Codes to requeue on
XPN$_ABORTED, XPN$_DISCONN, XPN$_NO_OPEN, XPN$_ABORT, XPN$_DEVOFFLINE,
XPN$_NO_MEMORY, XPN$_NO_LINKS, XPN$_NOSUCHNODE, XPN$_UNREACH, XPN$_NOSUCHOBJ,
XPN$_REJECTED, XPN$_TIMEOUT, XPN$_RESALLOC, XPN$_THIRD, XPN$_PMR_ERROR
%;
LOCAL retcode;
SELECTONE .statuscode OF
SET
[RMS$_FLK] : retcode = FALSE; ! File locked? requeue
[RMS$_DCF,
RMS$_DCB] : BEGIN ! for these two, examin the 2ndary code
IF .statuscode_2ndary NEQ 0 ! Is there a valid 2ndary code?
THEN SELECTONE .statuscode_2ndary OF
SET
[requeue_codes] : retcode = FALSE; ! Requeueable 2ndary
[OTHERWISE] : retcode = TRUE; ! Giveup on any other
TES
ELSE retcode = TRUE; ! And if there is no 2ndary code, punt
END;
[RMS$K_SUC_MIN TO
RMS$K_SUC_MAX] : retcode = FALSE; ! If it was an RMS success then requeue
[RMS$K_ERR_MIN TO
RMS$K_ERR_MAX] : retcode = TRUE; ! Giveup on all other RMS errors
[requeue_codes] : retcode = FALSE; ! Primary codes that requeue
[OTHERWISE] : IF .statuscode ! if none of the above,
THEN retcode = FALSE ! and BLISS-style success then reque
ELSE retcode = TRUE; ! otherwise giveup the request
TES; ! End of SELECTONE
RETURN(.retcode); ! Return TRUE to giveup the request
END;
GLOBAL ROUTINE ipc_connect_me (p_pdb) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
! Handle a request from a slave job to be connected to some directory.
!
! FORMAL PARAMETERS:
! p_pdb - pointer to Packet Descriptor Block for message
!
! SIDE EFFECTS:
! The slave job is connected to the desired directory.
!
!--
BEGIN
BIND pdb = .p_pdb : $$PDB_DECL,
message = ip_page : BLOCK [512] FIELD (DIUQ$$MESSAGE_FIELDS);
LOCAL job,
job_handle,
retcode,
target_dir_num,
target_dir_descr : $STR_DESCRIPTOR (CLASS = FIXED),
req_block : REF $DIU_BLOCK;
! Find the job status block for this slave.
job = .message[DIUQ$H_SENDER_JOB];
job_handle = .message[DIUQ$G_JOB_HANDLE];
IF .job NEQ .jobstatus[.job_handle, DIUJ$H_JOB_NUMBER]
THEN BEGIN
SIGNAL (DIU$_INV_IPCF_MSG);
RETURN;
END;
req_block = .jobstatus[.job_handle, DIUJ$A_REQ_BLOCK];
target_dir_num = .message[DIUQ$G_COMP_CODE];
! Insure that the directory the slave is requesting is the same as
! that in the request block. This MIGHT not be strictly necessary,
! but is good insurance against security bugs.
$STR_DESC_INIT (DESCRIPTOR = target_dir_descr, CLASS = FIXED,
STRING = (.req_block[DIU$H_CONNECTED_DIRECTORY],
CH$PTR (req_block[DIU$T_CONNECTED_DIRECTORY])));
IF s$dirno (target_dir_descr) NEQ .target_dir_num
THEN retcode = DIU$_NO_CONNECT
ELSE retcode = s$connect(.job, .target_dir_num);
! Return response to slave job
IF NOT .retcode
THEN BEGIN
ip_page[DIUQ$G_COMP_CODE] = .retcode;
ip_page[DIUQ$B_FUNCTION] = DIUQ$K_NACK;
END
ELSE ip_page[DIUQ$B_FUNCTION] = DIUQ$K_ACK;
ip$send (.pdb[PDB$$G_SENDER_PID], rcvpid, ip_page, 512);
END; ! End of ipc_connect_me
END ! End of module
ELUDOM