Trailing-Edge
-
PDP-10 Archives
-
bb-h138f-bm
-
7-sources/diuque.b36
There are 4 other files named diuque.b36 in the archive. Click here to see a list.
%TITLE 'DIUQUE - Queue Handling Routines'
MODULE DIUQUE (IDENT = '252',
LANGUAGE(BLISS36),
ENTRY(q$init, ! Open the queue file and set things up
q$enter, ! Enter a request in the queue
q$delete, ! Delete a request
q$modify, ! Modify a request
q$find, ! Find a request, return req. block(s)
q$pick, ! Pick a request for processing
q$reque ! Reque a (already picked) request
)
) =
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-10/20. (Data Interchange Utility)
!
! ABSTRACT: This module provides queue management for DIU-10/20.
!
! ENVIRONMENT: BLISS-36 V4, XPORT V4, RMS-10/20 V3
! TOPS-10 V7.03 or TOPS-20 V6.1
!
! The queue is maintained as an RMS relative file. The request-ID is
! the record number of the request record. Record 1 is a header record,
! with pointers to two record chains: the chain of pending requests,
! ordered by priority, and the chain of deleted records. Deleted records
! are never actually deleted from the RMS file, but are reused.
!
! AUTHOR: Rick Fricchione CREATION: August 10, 1984
! HISTORY:
!
! 252 Remove library of CONDIT.
! Sandy Clemens 1-Jul-86
!
! 234 Change library of RMSUSR to RMSINT.
! Gregory A. Scott 17-Jul-86
!
! 174 Remove library of TOPS20, use routine wild_match instead of wild jsys.
! Gregory A. Scott 20-May-86
!
! 160 If the queue file was written by another version we got all confused.
! The problem was that if the $GET for record 1 wouldn't work then we
! decided that the queue file didn't exist. Now we check for RMS$_RNF
! error to determine that the queue file is virgin, which is the right
! way to do it.
! Gregory A. Scott 14-May-86
!
! 152 Routines kill_job and q$copy_req_block were defined as external here
! but were never called. Make queue initializing message a real event.
! Gregory A. Scott 11-May-86
!
! 127 Remove hack to Q$MODIFY where if you were given a negative prerequisite
! request id then you would turn on the SEQ_CONTINUE bit. This is all
! removed because of the new (sensible) use of /PREREQ and /SEQUENCE.
! Gregory A. Scott 26-Apr-86
!
! 122 Protect the QUE file 0 under TOPS-20.
! Gregory A. Scott 22-Apr-86
!
! 111 Change queue file initialization messge.
! Andy Puchrik 3-Apr-86
!
! 102 Change routine Q$FIND_NODE to Q$FNODE so that LINK doesn't grab Q$FIND.
! Gregory A. Scott 28-Mar-86
!
! DPR0001 V01-04 Doug Rayner 29-Jul-85
! Some minor changes for TOPS-10. Put the QUE file in SYS:.
! Replace WILD% JSYS with call to routine that emulates it.
! Support [P,Pn]'s in find routine.
!
! RDF0001 V01-03 Rick Fricchione 21-Aug-1984
! Modify for DIU. Make it work with the new RMS-20. Fix some
! bugs in the dependency code, and clean up to be readable!
!
! AWN0001 V01-02 Andrew Nourse - no date -
! Put in entry points, and clean up code.
!
!--
!**************************************************************************
! L I B R A R Y A N D R E Q U I R E F I L E S
!**************************************************************************
LIBRARY 'DIU'; ! DIU Data structures
LIBRARY 'RMSINT'; ! RMS symbols
LIBRARY 'BLI:XPORT'; ! XPORT symbols
!****************************************************************************
! F O R W A R D R O U T I N E
!****************************************************************************
FORWARD ROUTINE
q$init, ! Open the queue file and set things up
q$enter, ! Enter a request in the queue
q$delete, ! Delete a request
q$modify, ! Modify a request
q$find, ! Find a request, return req. block(s)
q$$find_ch, ! Condition handler for q$find
q$pick, ! Pick a request for processing
q$reque, ! Reque a (already picked) request
q$$lower_priority, ! Test priority of two requests
q$$assign_sequence_no, ! Assign a new sequence number
q$$match_block; ! See if two request records match
!*****************************************************************************
!** M A C R O S
!*****************************************************************************
MACRO
queue$$_filespec =
%IF NOT %SWITCHES(DEBUG)
%THEN %IF %SWITCHES (TOPS20) ! Production version of file
%THEN 'SYSTEM:DIU.QUE;P000000' ! Protection 0
%FI
%IF %SWITCHES (TOPS10)
%THEN 'STD:DIU.QUE'
%FI
%ELSE %IF %SWITCHES (TOPS20)
%THEN 'SYSTEM:DIUDEB.QUE;P000000' ! Protection 0
%FI
%IF %SWITCHES (TOPS10)
%THEN 'STD:DIUDEB.QUE'
%FI
%FI %,
! The header record uses certain fields as pointers to records. Here
! are the correspondences.
HDR$H_DELETED_CHAIN = DIU$H_DEPENDENT_ID %,
HDR$H_PENDING_CHAIN = DIU$H_NEXT_RECORD %,
HDR$H_LENGTH = DIU$H_LENGTH %,
HDR$H_FIRST_FREE = DIU$H_PREV_RECORD %;
LITERAL
minute = %O'1000000' / (24*60), ! One minute, universal date/time form
requeue_time = 10*minute; ! Ten minutes -- requeue interval
OWN
q_fab : $FAB_DECL; ! FAB for the queue file
!*************************************************************************
! E X T E R N A L R O U T I N E S
!*************************************************************************
EXTERNAL ROUTINE
wild_match, ! Do a WILD% JSYS or a simulation
l$event : NOVALUE, ! Write event to system log file
q$req_block_init : NOVALUE, ! Init a request block
q$release_chain : NOVALUE, ! Release chain of blocks in heap space
q$valid_req_block, ! Validate a request block
q$fnode, ! Find a node in a filespec buffer
s$time, ! Return current system date/time
DIU$ABORT, ! DIU conditon handler
rms$efail : NOVALUE, ! RMS error message printer
rms$failure : NOVALUE; ! Default RMS failure handler
!***********************************************************************
! D E B U G G I N G R O U T I N E S
!***********************************************************************
%IF %SWITCHES (DEBUG)
%THEN
ROUTINE q$$debug_routine (arg) = 0;
%FI
!*************************************************************************
! Q $ I N I T
!*************************************************************************
GLOBAL ROUTINE q$init =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine opens the queue file, checks to see if the header
! record exists and creates it if it doesn't, and sets up various
! module-wide parameters.
!
! FORMAL PARAMETERS:
! NONE
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL - queue initialized OK
! some RMS code - RMS error prevented queue initialization
!
! SIDE EFFECTS:
! NONE
!
!--
LOCAL rab : $RAB_DECL,
req_block : $DIU_BLOCK,
next_record;
ENABLE DIU$ABORT; ! Enable condition handler
! Initialize the queue $FAB
$FAB_INIT (FAB=q_fab, FNA=queue$$_filespec,
FAC=(GET,PUT,DEL,UPD),ORG=REL,
SHR=(GET,PUT,DEL,UPD),FOP=CIF,
RAT=BLK, MRS=DIU$K_CHAR_COUNT);
! Initialize the queue $RAB
$RAB_INIT (RAB=rab, FAB=q_fab, RAC=KEY);
! Create or open the file as appropriate
$CREATE (FAB=q_fab);
IF NOT $RMS_STATUS_OK (q_fab)
THEN SIGNAL (DIU$_DAMAGED, .q_fab[FAB$H_STS]);
! Connect RAB to FAB
$CONNECT (RAB=rab);
IF NOT $RMS_STATUS_OK (rab)
THEN SIGNAL (DIU$_DAMAGED, .rab[RAB$H_STS]);
! Look up record 1 (header record).
$RAB_STORE (RAB=rab, KBF=(UPLIT (1)), UBF=req_block, USZ=DIU$K_LEN);
$GET (RAB=rab);
! Check the status returned from the $GET. If it was record not found, then
! we must have created a new queue file here.
IF .rab[RAB$H_STS] EQL RMS$_RNF ! If it was record not found
THEN BEGIN ! Then we must have a new queue file
L$EVENT (DIU$_INIT_QUEUE, 0, 0); ! Give message to log file
q$req_block_init (req_block); ! Get a clean request block
! Header record is considered to be deleted. There is as yet no
! chain of deleted records so DIU$H_NEXT_RECORD is set to zero.
! DIU$H_REQUEST_ID is set to 2 (the first available record).
req_block[DIU$V_DELETED] = 1;
req_block[HDR$H_DELETED_CHAIN] = 0;
req_block[HDR$H_PENDING_CHAIN] = 0;
req_block[HDR$H_FIRST_FREE] = 2;
req_block[HDR$H_LENGTH] = DIU$K_LEN;
$RAB_STORE (RAB=rab, RBF=req_block, RSZ=DIU$K_CHAR_COUNT);
$PUT (RAB=rab); ! Put the header record there
IF NOT $RMS_STATUS_OK (rab) ! Punt if the put didn't work
THEN SIGNAL (DIU$_DAMAGED, .rab[RAB$H_STS]);
END
! The status returned wasn't record not found. Make sure that the $GET worked,
! the length is proper, and the queue file is the proper version.
ELSE IF NOT ($RMS_STATUS_OK (rab)
AND .req_block[HDR$H_LENGTH] EQL DIU$K_LEN
AND .req_block[DIU$H_VERSION] EQL DIU$K_VERSION)
THEN SIGNAL(DIU$_ANOTHER_VERSION, .rab[RAB$H_STS]);
! Now scan through the chain, requeuing any active requests (presumably
! left over from a system crash). Signal errors if there is/was a punt
next_record = .req_block[HDR$H_PENDING_CHAIN];
WHILE .next_record NEQ 0
DO BEGIN
$RAB_STORE (RAB=rab, KBF=next_record, UBF=req_block, USZ=DIU$K_LEN);
$GET (RAB = rab);
IF NOT $RMS_STATUS_OK (rab)
THEN BEGIN
$DISCONNECT (RAB = rab);
SIGNAL (DIU$_DAMAGED, .rab[RAB$H_STS])
END;
next_record = .req_block[DIU$H_NEXT_RECORD];
IF .req_block[DIU$V_ACTIVE]
THEN BEGIN ! Free record so requeue can hack on it
$FREE (RAB = rab, ERR = rms$failure);
Q$REQUE(.req_block[DIU$H_REQUEST_ID]);
END;
END; %(while more records)%
! Disassociate ourselves with the file and return OK
$DISCONNECT (RAB=rab, ERR=rms$failure);
RETURN (DIU$_NORMAL);
END; ! End of q$init
!*********************************************************************
!* Q $ E N T E R
!*********************************************************************
GLOBAL ROUTINE q$enter (p_req_block) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! Enter a request in the queue. The information in the request block
! is copied to a record which is written to the RMS file containing
! the queue. The new record is linked into the chain of pending
! requests in front of the first request with lower priority (i.e.,
! the chain is orderd by priority).
!
! FORMAL PARAMETERS:
! p_req_block - pointer to request block
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! The RMS queue file is updated with the new entry.
! DIU$H_REQUEST_ID is updated with the sequence number assigned
! to this request.
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL - request entered OK
! DIU$_INVALID_REQUEST - the request block is invalid
! DIU$_RMS_ERROR - unexpected RMS error
!
! SIDE EFFECTS:
! The header record is updated to reflect the sequence number assigned.
!
!--
BIND
req_block = .p_req_block : $DIU_BLOCK;
LOCAL
rab : $RAB_DECL,
tmp_block : $DIU_BLOCK,
previous,
next,
req_id,
retcode;
IF .req_block[DIU$H_REQUEST_ID] NEQ 0
THEN SIGNAL (DIU$_INVALID_REQUEST);
! They can't give us the id, we assign it.
IF NOT (retcode = Q$VALID_REQ_BLOCK(req_block))
THEN RETURN (SIGNAL (.retcode));
! Validate the contents of the block
req_id = req_block[DIU$H_REQUEST_ID] = Q$$ASSIGN_SEQUENCE_NO();
IF .req_ID EQL -1
THEN RETURN (DIU$_QUEUE_FULL);
! Get the id and return if the queue was full
$RAB_INIT (RAB=rab, FAB=q_fab, RAC=KEY);
$CONNECT (RAB=rab, ERR=rms$failure);
$RAB_STORE (RAB=rab, RBF=req_block, RSZ=DIU$K_CHAR_COUNT,KBF=req_id);
$FIND (RAB=rab, ERR=rms$failure);
$UPDATE (RAB=rab, ERR=rms$failure);
! Assign the next sequence number, stuff into record, stuff current
! date/time into record, and write the record to the queue file.
! Now scan the list of pending requests looking for the first of
! lower priority. First get the header record, which anchors the chain.
$RAB_STORE (RAB=rab,KBF=(UPLIT (1)),UBF=tmp_block,USZ=DIU$K_LEN);
$GET (RAB=rab,ERR=rms$failure);
! Get the header record, and prepare to scan the chain of pending requests
! looking for the first one with lower priority.
previous = 1;
next = .tmp_block[HDR$H_PENDING_CHAIN];
! Note the header and first *real* record
WHILE .next NEQ 0 DO
BEGIN
$RAB_STORE (RAB=rab,KBF=next,UBF=tmp_block,USZ=DIU$K_LEN);
$GET (RAB=rab,ERR=rms$failure);
IF Q$$LOWER_PRIORITY (tmp_block, req_block)
THEN BEGIN
req_block[DIU$H_PREV_RECORD] = .previous;
req_block[DIU$H_NEXT_RECORD] = .next;
! We found one lowlier than us. Point to previous
! and next records.
$RAB_STORE(RAB=rab,KBF=req_id,RBF=req_block,RSZ=DIU$K_CHAR_COUNT);
$FIND (RAB=rab, ERR=rms$failure);
$UPDATE (RAB=rab, ERR=rms$failure);
$RAB_STORE (RAB=rab,KBF=previous,UBF=tmp_block,USZ=DIU$K_LEN);
$GET (RAB=rab,ERR=rms$failure);
tmp_block[DIU$H_NEXT_RECORD] = .req_id;
$UPDATE (RAB=rab,ERR=rms$failure);
! Get previous record and make us its next
! Get next record and make us its previous
$RAB_STORE (RAB=rab, KBF=next);
$GET (RAB=rab, ERR=rms$failure);
tmp_block[DIU$H_PREV_RECORD] = .req_id;
$UPDATE (RAB=rab, ERR=rms$failure);
$DISCONNECT (RAB=rab, ERR=rms$failure);
RETURN (DIU$_NORMAL)
END; %(found lower priority)%
next = .tmp_block[DIU$H_NEXT_RECORD];
previous = .tmp_block[DIU$H_REQUEST_ID];
! Were it guys...
END; %(while)%
$RAB_STORE (RAB=rab,KBF=req_id,RBF=req_block,RSZ=DIU$K_CHAR_COUNT);
$FIND (RAB=rab,ERR=rms$failure);
req_block[DIU$H_PREV_RECORD] = .previous;
req_block[DIU$H_NEXT_RECORD] = 0;
$UPDATE (RAB = rab, ERR = rms$failure);
$RAB_STORE (RAB=rab,KBF=previous,RBF=tmp_block,RSZ=DIU$K_CHAR_COUNT);
$FIND (RAB=rab,ERR=rms$failure);
tmp_block[DIU$H_NEXT_RECORD] = .req_id;
$UPDATE (RAB=rab,ERR=rms$failure);
$DISCONNECT (RAB=rab,ERR=rms$failure);
! If we fell out of the loop, we are the lowliest guy. Just point
! previous at us and return.
RETURN (DIU$_NORMAL);
END; ! End of q$enter
!************************************************************************
! Q $ D E L E T E
!************************************************************************
GLOBAL ROUTINE q$delete (request_ID) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! Delete a request from the queue.
!
! FORMAL PARAMETERS:
! request-ID - the request-ID (record no.) of the req. to be deleted
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! The entry is marked as deleted and is inserted at the head of the
! deleted entry queue.
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL - request entered OK
! DIU$_INVALID_REQUEST - invalid request block presented
! DIU$_REQ_NOT_FOUND - request not found in queue
!
! SIDE EFFECTS:
! NONE
!
!--
LOCAL
rab : $RAB_DECL,
req_block : $DIU_BLOCK, ! Request block being deleted
hdr_block : $DIU_BLOCK, ! Header block
previous,
next;
IF .request_ID LEQ 1 THEN SIGNAL (DIU$_INVALID_REQUEST);
! Can't delete record 0 or the header record..
$RAB_INIT(RAB=rab,FAB=q_fab,RAC=KEY);
$CONNECT(RAB=rab,ERR=rms$failure);
$RAB_STORE(RAB=rab,KBF = request_ID,UBF=req_block,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
! Get the request they wish to delete...
IF (NOT $RMS_STATUS_OK (rab)) OR .req_block[DIU$V_DELETED]
THEN BEGIN
$DISCONNECT (RAB = rab);
SIGNAL (DIU$_REQ_NOT_FOUND);
RETURN (0);
END;
! If its already deleted, or its not there, just fail
req_block[DIU$V_DELETED] = 1;
$UPDATE (RAB = rab, ERR = rms$failure);
! Mark the request as deleted.
previous = .req_block[DIU$H_PREV_RECORD];
next = .req_block[DIU$H_NEXT_RECORD];
! Get ready to de-link the record
IF .previous NEQ 0
THEN BEGIN
$RAB_STORE(RAB=rab,KBF=previous);
$GET(RAB=rab,ERR=rms$failure);
! Get the previous record
req_block[DIU$H_NEXT_RECORD] = .next;
$RAB_STORE(RAB=rab,KBF=previous,RBF=req_block,RSZ=DIU$K_CHAR_COUNT);
$UPDATE(RAB=rab,ERR=rms$failure);
! Update the pointer and put it back
END;
IF .next NEQ 0
THEN BEGIN
$RAB_STORE(RAB=rab,KBF=next);
$GET(RAB=rab,ERR=rms$failure);
! Get the next record
req_block[DIU$H_PREV_RECORD] = .previous;
$RAB_STORE(RAB=rab,KBF=next,RBF=req_block,RSZ=DIU$K_CHAR_COUNT);
$UPDATE(RAB=rab,ERR=rms$failure);
! Update the pointer and put it back
END;
$RAB_STORE(RAB=rab,KBF=request_ID);
$GET(RAB=rab,ERR=rms$failure);
! Get the deleted record back
$RAB_STORE(RAB=rab,KBF=(UPLIT(1)),UBF=hdr_block,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
! Get the header record back
req_block[DIU$H_NEXT_RECORD] = .hdr_block[HDR$H_DELETED_CHAIN];
hdr_block[HDR$H_DELETED_CHAIN] = .request_ID;
! Point this record at head of chain, and record 1 at this record.
$RAB_STORE(RAB=rab,KBF=request_ID,RBF=req_block,RSZ=DIU$K_CHAR_COUNT);
$FIND(RAB=rab,ERR=rms$failure);
$UPDATE(RAB=rab,ERR=rms$failure);
! Write this record out first (so system crash doesn't result
! in record 1 pointing to empty chain, thus losing deleted records)
$RAB_STORE(RAB=rab,KBF=(UPLIT(1)),RBF=hdr_block,RSZ=DIU$K_CHAR_COUNT);
$FIND(RAB=rab,ERR=rms$failure);
$UPDATE(RAB=rab,ERR=rms$failure);
$DISCONNECT(RAB=rab,ERR=rms$failure);
! NOW write the header record
RETURN(DIU$_NORMAL);
END; ! End of q$delete
!**********************************************************************
!** Q $ M O D I F Y
!**********************************************************************
GLOBAL ROUTINE q$modify (req_ID, item_code, new_value) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Modify a parameter of a request in the queue. Since modifying the
! priority, /AFTER, or /DEADLINE parameters is likely to result in a
! reordering of the queue, MODIFY is implemented as a DELETE followed by
! an ENTER. We know the ENTER will assign the same request ID because
! deleted request ID's are maintained in a LIFO stack.
!
! FORMAL PARAMETERS:
! req_ID: request ID number
! item_code: code identifying item to change
! new_value: new value of item
!
! IMPLICIT OUTPUTS:
!
! The queue file entry is modified. If the modification alters the
! relative priority of the request, it will move to an appropriate place
! in the queue.
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL: successful completion
! DIU$_INVALID_FUNCTION: invalid item code
! DIU$_ACTIVE: can't modify an active request
!
!--
LOCAL
retcode,
chain_head,
original_req_ID,
req_block_template : $DIU_BLOCK,
req_block : REF $DIU_BLOCK;
! Cannot modify header record..
Q$REQ_BLOCK_INIT (req_block_template);
IF (original_req_id = req_block_template[DIU$H_REQUEST_ID] = .req_ID) LSS 2
THEN RETURN (DIU$_INVALID_REQUEST);
! Find this request
IF NOT (retcode = Q$FIND (req_block_template, chain_head))
THEN RETURN (.retcode);
! We had better have only one request block in the chain.
IF ..chain_head NEQ 0 THEN RETURN (DIU$_BUG);
! Address the request block proper
req_block = .chain_head + %UPVAL;
SELECTONE .item_code OF
SET
[DIUQ$K_AFTER] : req_block[DIU$G_AFTER] = .new_value;
[DIUQ$K_PRIORITY] : req_block[DIU$B_PRIORITY] = .new_value;
[DIUQ$K_DEADLINE] : req_block[DIU$G_DEADLINE] = .new_value;
[DIUQ$K_HOLDING] : req_block[DIU$V_HOLDING] = .new_value;
[DIUQ$K_DEPENDENT_ID] : req_block[DIU$H_DEPENDENT_ID] = .new_value;
[DIUQ$K_NOTIFY] : req_block[DIU$Z_NOTIFY] = .new_value;
[DIUQ$K_SEQUENCE] : req_block[DIU$V_SEQ_CONTINUE] = .new_value;
[DIUQ$K_PREREQUISITE_ID] : req_block[DIU$H_PREREQUISITE_ID] = .new_value;
[DIUQ$K_LOG_FILESPEC] :
BEGIN
MAP new_value : REF $STR_DESCRIPTOR ();
CH$MOVE (.new_value[STR$H_LENGTH],
.new_value[STR$A_POINTER],
CH$PTR (req_block[DIU$T_LOG_FILESPEC]));
req_block[DIU$H_LOG_FILESPEC] = .new_value[STR$H_LENGTH];
END;
[OTHERWISE] : RETURN (DIU$_INVALID_REQUEST);
TES; %(select)%
! Delete the existing version of the request
IF NOT (retcode = q$delete (.req_ID))
THEN BEGIN
q$release_chain (.chain_head);
RETURN (DIU$_BUG);
END;
! Zero the request id, and re-enter on the queue. Since we take from the
! deleted chain first, it should get the same request id.
req_block[DIU$H_REQUEST_ID] = 0;
IF NOT (retcode = Q$ENTER (.req_block))
THEN BEGIN
Q$RELEASE_CHAIN (.chain_head);
RETURN (DIU$_BUG);
END;
! Release the chain of request(s)
Q$RELEASE_CHAIN (.chain_head);
! Make sure it assigned the same request id.
IF .req_block[DIU$H_REQUEST_ID] NEQ .original_req_ID
THEN RETURN (DIU$_BUG);
RETURN (DIU$_NORMAL) ! Return OK
END; ! End of q$modify
!**********************************************************************
!** Q $ F I N D
!**********************************************************************
GLOBAL ROUTINE q$find (p_req_block, chain_returned) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! Find a request record, or records. Caller can specify:
! 1) A specific request-ID (at most one record will be returned)
! 2) A wildcarded request-block (matching records are returned)
! 3) An empty (zero) request-block (all request blocks are returned)
!
! FORMAL PARAMETERS:
! p_req_block - pointer to a request block.
! chain_returned - address to store pointer to chain of request
! blocks. The chain is of request blocks with
! one word prepended to the front of the block
! which is a pointer to the next block, or zero.
! The blocks are allocated in heap space with
! $XPO_GET_MEM and MUST BE FREED BY THE CALLER!
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL - successful completion
! DIU$_INVALID_REQUEST - request block invalid
! DIU$_QUEUE_EMPTY - queue is empty
! DIU$_REQ_NOT_FOUND - can't find the request
! DIU$_RMS_ERROR - unexpected RMS error
! DIU$_NO_MEMORY - insufficient heap space to satisfy request
!
! SIDE EFFECTS:
! NONE
!
!--
BIND
req_block = .p_req_block : $DIU_BLOCK;
LOCAL
rab : VOLATILE $RAB_DECL,
chain_head : VOLATILE,
hdr_record : $DIU_BLOCK,
req_ID,
last_block,
this_block,
this_record : REF $DIU_BLOCK,
next_record_number;
ENABLE
Q$$FIND_CH(chain_head, rab);
$RAB_INIT(RAB=rab,FAB=q_fab,RAC=KEY);
$CONNECT(RAB=rab,ERR=rms$failure);
! Init our RMS blocks
! Handle the case where they gave us a specific request id. Allocate a
! memory chain of one, and return that to the user.
IF .req_block[DIU$H_REQUEST_ID] NEQ 0
THEN BEGIN
IF NOT $XPO_GET_MEM(UNITS=DIU$K_LEN+%UPVAL,RESULT=this_block)
THEN SIGNAL (DIU$_NO_MEMORY);
! Get one block in heap space
(.this_block) = 0;
! Zero next pointer (since only one should come back)
this_record = .this_block + %UPVAL;
! Address the request block proper
req_ID = .req_block[DIU$H_REQUEST_ID];
$RAB_STORE(RAB=rab,KBF=req_ID,UBF=.this_block+%UPVAL,USZ=DIU$K_LEN);
$GET(RAB=rab);
! Look up the record
IF (NOT ($RMS_STATUS_OK (rab))) OR .this_record[DIU$V_DELETED]
THEN BEGIN
$DISCONNECT(RAB=rab,ERR=rms$failure);
$XPO_FREE_MEM(BINARY_DATA=(DIU$K_LEN+%UPVAL,.this_block,UNITS));
(.chain_returned) = 0;
RETURN (DIU$_REQ_NOT_FOUND);
END;
! If there's no record, or if the record is deleted, fail. Set the
! return chain address to zero.
(.chain_returned) = .this_block;
$DISCONNECT (RAB = rab, ERR = rms$failure);
RETURN (DIU$_NORMAL)
! OK, return address of block allocated to caller
END; %(request id specified)%
! Request-ID not specified: we have to search the queue file for matches.
! Get the header record, which contains the pending record chain pointer.
$RAB_STORE(RAB=rab,KBF=(UPLIT(1)),UBF=hdr_record,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
next_record_number = .hdr_record[HDR$H_PENDING_CHAIN];
! Get header record and find pending chain
IF .next_record_number EQL 0
THEN BEGIN
$DISCONNECT (RAB = rab, ERR = rms$failure);
(.chain_returned) = 0;
RETURN (DIU$_QUEUE_EMPTY);
END;
! No pending requests in the queue.. sorry Jack
last_block = chain_head;
! The absence of a dot is intentional
! Now scan the chain of pending records, reading each one into a block
! in heap space. If the record matches what the caller specified, it
! is linked into the chain we're building. Otherwise the heap space
! is released and reused.
WHILE .next_record_number NEQ 0 DO
BEGIN
IF NOT $XPO_GET_MEM (UNITS=DIU$K_LEN+%UPVAL,RESULT=this_block)
THEN SIGNAL (DIU$_NO_MEMORY);
! Allocate a block in heap space into which to read the record
(.this_block) = 0;
! Zero next pointer
$RAB_STORE(RAB=rab,KBF=next_record_number,
UBF=.this_block+%UPVAL,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
IF NOT $RMS_STATUS_OK (rab)
THEN SIGNAL (DIU$_RMS_ERROR);
! Get this record
this_record = .this_block + %UPVAL;
next_record_number = .this_record[DIU$H_NEXT_RECORD];
! Found a record. See if it matches what caller supplied.
IF Q$$MATCH_BLOCK(req_block,.this_record)
THEN BEGIN
(.last_block) = .this_block;
last_block = .this_block;
END
! Record matches, link it in to the chain
ELSE $XPO_FREE_MEM(BINARY_DATA=(DIU$K_LEN+%UPVAL,.this_block, UNITS));
! Record doesn't match, release the heap space
END; %(while more requests)%
$DISCONNECT (RAB = rab, ERR = rms$failure);
! All done. Pass address of chain of blocks to caller and return.
(.chain_returned) = .chain_head;
IF .chain_head NEQ 0
THEN RETURN (DIU$_NORMAL)
ELSE RETURN (DIU$_REQ_NOT_FOUND)
END; ! End of q$find
!**********************************************************************
! Q $ $ F I N D _ C H
!**********************************************************************
ROUTINE q$$find_ch (sig, mech, enbl) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! Condition handler for q$find. Our task is to release dynamic
! memory acquired, disconnect the RAB, and cause q$find to return
! the appropriate failure code to its caller, by unwinding.
!
! FORMAL PARAMETERS:
! sig - signal vector
! mech - mechanism vector
! enbl - enable vector
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! NONE
!
!--
MAP
sig : REF VECTOR,
mech : REF VECTOR,
enbl : REF VECTOR;
BIND
completion_code = sig[1],
chain_head = .enbl[1],
rab = .enbl[2],
retval = mech[%BLISS16(1)
%BLISS32(3)
%BLISS36(1)];
IF .completion_code EQL STS$K_UNWIND
THEN RETURN (0);
! Handle unwinds through us..
IF .chain_head NEQ 0 THEN Q$RELEASE_CHAIN (.chain_head);
! If we had a chain, deallocate it..
$DISCONNECT(RAB=rab);
retval = .completion_code;
! Set the return value to what was SIGNAL'd
SETUNWIND ()
! Unwind the sucker..
END; ! End of q$$find_ch
!*****************************************************************
!** Q $ P I C K
!*****************************************************************
GLOBAL ROUTINE q$pick (p_req_block) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! Pick a request from the queue for processing.
!
! FORMAL PARAMETERS:
! p_req_block - pointer to request block
!
! IMPLICIT INPUTS:
! DIU$H_REQUEST_ID must contain a valid request ID.
!
! IMPLICIT OUTPUTS:
! The request is marked as active (DIU$V_ACTIVE), and the caller's request
! block is filled in.
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL - success
! DIU$_ACTIVE - request already active
! DIU$_REQ_NOT_FOUND - no such request
! DIU$_RMS_ERROR - unexpected RMS error
! DIU$_HOLD - request is on hold by operator
!
! SIDE EFFECTS:
! NONE
!
!--
BIND
req_block = .p_req_block : $DIU_BLOCK;
LOCAL
rab : $RAB_DECL,
req_ID;
IF .req_block[DIU$H_REQUEST_ID] EQL 0
THEN RETURN (DIU$_INVALID_REQUEST);
! Cannot pick request 0 out of the queue..
$RAB_INIT(RAB=rab,FAB=q_fab);
$CONNECT(RAB=rab,ERR=rms$failure);
! Init and connect the RMS blocks
req_ID = .req_block[DIU$H_REQUEST_ID];
$RAB_STORE(RAB=rab,RAC=KEY,KBF=req_ID,UBF=req_block,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
IF (NOT $RMS_STATUS_OK (rab))
THEN BEGIN
$DISCONNECT (RAB = rab);
RETURN (DIU$_RMS_ERROR)
END;
! Get the record
IF .req_block[DIU$V_DELETED]
THEN BEGIN
$DISCONNECT (RAB = rab);
RETURN (DIU$_REQ_NOT_FOUND)
END;
! Sorry, its deleted..
IF .req_block[DIU$V_ACTIVE]
THEN BEGIN
$DISCONNECT (RAB = rab);
RETURN (DIU$_ACTIVE)
END;
! Its already being used...
req_block[DIU$V_ACTIVE] = 1;
$UPDATE (RAB = rab, ERR = rms$failure);
! Request passes all tests. Set DIU$V_ACTIVE and return.
IF (NOT $RMS_STATUS_OK (rab))
THEN BEGIN
$DISCONNECT (RAB = rab);
RETURN (DIU$_RMS_ERROR);
END;
! Check to make sure it was updated
$DISCONNECT (RAB = rab);
! Let go of the queue
RETURN DIU$_NORMAL;
END; ! End of q$pick
!******************************************************************
!** Q $ R E Q U E U E
!******************************************************************
GLOBAL ROUTINE q$reque (req_ID) =
BEGIN
!++
!
! FUNCTIONAL DESCRIPTION:
!
! Requeue an already picked (q$pick) request.
!
! FORMAL PARAMETERS:
! req_ID - request ID no. of the request
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! DIU$V_ACTIVE is cleared.
!
! ROUTINE VALUE and
! COMPLETION CODES:
! DIU$_NORMAL - OK
! DIU$_RMS_ERROR - unexpected RMS error
! DIU$_ACTIVE - request was not active
!
! SIDE EFFECTS:
! NONE
!
!--
LOCAL
req_block : $DIU_BLOCK,
rab : $RAB_DECL;
$RAB_INIT(RAB=rab,FAB=q_fab,RAC=KEY);
$CONNECT(RAB=rab,ERR=rms$failure);
$RAB_STORE(RAB=rab,RAC=KEY,KBF=req_ID,UBF=req_block,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
! Get the record
IF NOT $RMS_STATUS_OK (rab)
THEN BEGIN
$DISCONNECT(RAB=rab);
RETURN (DIU$_RMS_ERROR)
END;
! It had better be found...
req_block[DIU$V_ACTIVE] = 0;
! Turn off active flag
req_block[DIU$G_AFTER] = s$time () + requeue_time;
! Set /AFTER to 10 minutes from now, to avoid infinite resource hoggage
req_block[DIU$G_REQUEUE_COUNT] = .req_block[DIU$G_REQUEUE_COUNT] + 1;
! Increment requeue count
$UPDATE(RAB=rab,ERR=rms$failure);
IF NOT $RMS_STATUS_OK (rab)
THEN BEGIN
$DISCONNECT(RAB=rab);
RETURN (DIU$_RMS_ERROR);
END;
! Update the record..
$DISCONNECT(RAB=rab);
! Get rid of queue file
RETURN (DIU$_NORMAL)
! I don't think we're in Kansas anymore Toto...
END; ! End of q$reque
!************************************************************
!** Q $ $ L O W E R _ P R I O R I T Y
!************************************************************
ROUTINE q$$lower_priority (p_block1, p_block2) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! Test to see if block1 is of lower priority than block2.
!
! FORMAL PARAMETERS:
! p_block1 - pointer to request block
! p_block2 - pointer to request block
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! 1 - block 1 is of lower priority than block 2
! 0 - block 1 is not of lower priority than block 2
!
! SIDE EFFECTS:
! NONE
!
!--
BIND
block1 = .p_block1 : $DIU_BLOCK,
block2 = .p_block2 : $DIU_BLOCK;
IF .block1[DIU$B_PRIORITY] LSS .block2[DIU$B_PRIORITY]
THEN RETURN (1);
! If block1's priority code is lower, it is definitely of lower priority
IF .block1[DIU$B_PRIORITY] NEQ .block2[DIU$B_PRIORITY]
THEN RETURN (0);
! If the priority codes are unequal (that is, block1 has higher priority
! code) there's no way block1 can be of lower priority, so return false.
IF .block1[DIU$G_AFTER] NEQ .block2[DIU$G_AFTER]
THEN RETURN (0);
IF .block1[DIU$G_AFTER] GTR .block2[DIU$G_AFTER]
THEN RETURN (1);
! The requests have equal priorities. Test according to /AFTER.
IF .block2[DIU$G_DEADLINE] NEQ 0
THEN IF .block1[DIU$G_DEADLINE] EQL 0
THEN RETURN (1)
ELSE IF .block1[DIU$G_DEADLINE] GTR .block2[DIU$G_DEADLINE]
THEN RETURN (1);
! The /AFTER switches are equal. Check /DEADLINE.
RETURN (0)
! We failed all tests. Report that block1 is NOT of lower priority.
END; ! End of q$$lower_priority
!********************************************************************
!** Q $ $ A S S I G N _ S E Q U E N C E _ N O
!********************************************************************
ROUTINE q$$assign_sequence_no =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
! Assign an unused sequence number.
!
! FORMAL PARAMETERS:
! NONE
!
! IMPLICIT INPUTS:
! The chain of deleted records (pointed to by record 1) is checked.
! If it's nonempty, the first such record is delinked and returned
! to the caller. Otherwise, we append a record to the file and return
! its ID.
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! The sequence number assigned is returned. If the queue is full,
! we return -1.
!
! SIDE EFFECTS:
! NONE
!
!--
LOCAL
rab : $RAB_DECL, ! RAB for queue file
hdr_record : $DIU_BLOCK, ! Header record
del_record : $DIU_BLOCK, ! Deleted record
tmp_pointer;
$RAB_INIT(RAB=rab,FAB=q_fab,RAC=KEY);
$CONNECT(RAB=rab,ERR=rms$failure);
$RAB_STORE(RAB=rab,KBF=(UPLIT(1)),UBF=hdr_record,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
IF NOT $RMS_STATUS_OK (rab)
THEN $XPO_PUT_MSG (SEVERITY = FATAL, STRING = 'Cannot find header record');
! Get the header record to see if we have a deleted chain
IF .hdr_record[HDR$H_DELETED_CHAIN] NEQ 0
THEN BEGIN
!
! We do have a deleted record chain. Dequeue the first record
! and return its number to our caller.
!
LOCAL
record_number;
record_number = .hdr_record[HDR$H_DELETED_CHAIN];
$RAB_STORE(RAB=rab,KBF=record_number,UBF=del_record,USZ=DIU$K_LEN);
$GET(RAB=rab,ERR=rms$failure);
IF NOT $RMS_STATUS_OK (rab)
THEN $XPO_PUT_MSG (SEVERITY = FATAL,
STRING = 'Cannot find first deleted record');
! Get the first deleted record
hdr_record[HDR$H_DELETED_CHAIN] = .del_record[DIU$H_NEXT_RECORD];
$RAB_STORE(RAB=rab,KBF=(UPLIT(1)),RBF=hdr_record,RSZ=DIU$K_CHAR_COUNT);
$FIND(RAB=rab,ERR=rms$failure);
$UPDATE(RAB=rab,ERR=rms$failure);
$DISCONNECT(RAB=rab);
! Update the pointer to the deleted chain and put back
del_record[DIU$V_DELETED] = 0;
del_record[DIU$V_ACTIVE] = 0;
! Clear the deleted and active flags
RETURN (.del_record[DIU$H_REQUEST_ID]);
! Return, giving the request id
END; %(deleted chain exists)%
! No deleted record chain exists. Append a new record to the file
! (hdr_record[DIU$H_REQUEST_ID] points to 1st unused record in file).
! The request ID is set to the relative record number. If we're
! at record 250, though, the queue is full, so return -1.
tmp_pointer = .hdr_record[HDR$H_FIRST_FREE];
IF .tmp_pointer GEQ (250 + 3)
THEN BEGIN
$DISCONNECT(RAB=rab,ERR=rms$failure);
RETURN (-1);
END;
! Grab one from the free list
Q$REQ_BLOCK_INIT(del_record);
$RAB_STORE(RAB=rab,KBF=tmp_pointer,RBF=del_record,RSZ=DIU$K_CHAR_COUNT);
$PUT(RAB=rab,ERR=rms$failure);
! write the record
hdr_record[HDR$H_FIRST_FREE] = 1 +
(del_record[DIU$H_REQUEST_ID]=.rab[RAB$G_BKT]);
! Update first free record field in header record
$RAB_STORE(RAB=rab,KBF=(UPLIT(1)),RBF=hdr_record,RSZ=DIU$K_CHAR_COUNT);
$FIND(RAB=rab,ERR=rms$failure);
$UPDATE(RAB=rab,ERR=rms$failure);
! Put the header record back
$DISCONNECT(RAB=rab,ERR=rms$failure);
RETURN (.del_record[DIU$H_REQUEST_ID])
END; ! End of q$$assign_sequence_no
!********************************************************************
! Q $ $ M A T C H _ B L O C K
!********************************************************************
ROUTINE q$$match_block (p_try_block, p_target_block) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
! Test to see if a request block can match a given request block.
! The "try" block can be very sparse (in fact, if it is totally zero,
! this routine will return success). If all data specified in try_block
! match the corresponding data in target_block, success is returned.
! Wildcarding is allowed.
!
! If there is anything in the source filespec portion of the request block,
! it is assumed to be the source node to match. If anything in the
! destination file, it is assumed to be the destination node. Node names
! must have colons ("::") attached.
!
! FORMAL PARAMETERS
!
! p_try_block - pointer to the (partial) block to test for a match
! p_target_block - pointer to target block
!
! IMPLICIT INPUTS
! NONE
!
! IMPLICIT OUTPUTS
! NONE
!
! ROUTINE VALUE
!
! TRUE: match
! FALSE: no match
!--
MACRO matchwild [field_name]=
BEGIN
LOCAL length;
IF (length = .try_block[%NAME ('DIU$H_', field_name)]) NEQ 0
THEN BEGIN
LOCAL tlength,
result,
try_buff : VECTOR [CH$ALLOCATION (40)],
targ_buff : VECTOR [CH$ALLOCATION (40)];
! Check length of the fields first
tlength = .target_block[%NAME ('DIU$H_', field_name)];
IF (.length GTR 40) OR (.tlength GTR 40) THEN RETURN (0);
! Make the try buffer argument ASCIZ
CH$COPY(.length,CH$PTR(try_block[%NAME('DIU$T_',field_name)]),
0,.length+1,CH$PTR(try_buff));
! Make the argument buffer ASCIZ
CH$COPY(.tlength,CH$PTR(target_block[%NAME('DIU$T_',field_name)]),
0,.tlength + 1, CH$PTR (targ_buff));
! Test the ASCIZ strings.. and return false if no match
IF NOT wild_match(CH$PTR(try_buff),CH$PTR(targ_buff))
THEN RETURN FALSE;
END; ! length not equal 0
END %; ! macro matchwild
BIND try_block = .p_try_block : $DIU_BLOCK,
target_block = .p_target_block : $DIU_BLOCK;
LOCAL src_node,
dst_node,
node : $STR_DESCRIPTOR(CLASS=DYNAMIC),
buff : $STR_DESCRIPTOR(CLASS=DYNAMIC);
! If the target is deleted then return false
IF .target_block[DIU$V_DELETED] THEN RETURN FALSE;
! If the request id isn't zero and they don't match, return false
IF .try_block[DIU$H_REQUEST_ID] NEQ 0
THEN IF .try_block[DIU$H_REQUEST_ID] NEQ .target_block[DIU$H_REQUEST_ID]
THEN RETURN FALSE;
%IF %SWITCHES (TOPS10) %THEN ! TOPS-10 ONLY
! If the user id isn't zero and they don't match, return false
IF .try_block[DIU$G_USER_NUMBER] NEQ 0
THEN IF .try_block[DIU$G_USER_NUMBER] NEQ .target_block[DIU$G_USER_NUMBER]
THEN RETURN FALSE;
%FI ! END TOPS-10 ONLY
! Make sure the jobname and username match if they are specified
MATCHWILD (jobname,username);
! If they gave us a node name to match, try and find it in either the
! source or destination filespec buffers. If it isn't there, fail.
IF (.try_block[DIU$H_SOURCE_FILESPEC] GTR 0)
THEN BEGIN
IF NOT (Q$FNODE(target_block[DIU$T_SOURCE_FILESPEC],
.target_block[DIU$H_SOURCE_FILESPEC],
try_block[DIU$T_SOURCE_FILESPEC],
.try_block[DIU$H_SOURCE_FILESPEC])
OR Q$FNODE(target_block[DIU$T_DESTINATION_FILESPEC],
.target_block[DIU$H_DESTINATION_FILESPEC],
try_block[DIU$T_SOURCE_FILESPEC],
.try_block[DIU$H_SOURCE_FILESPEC]))
THEN RETURN FALSE;
END;
! All identifying fields matched. Return true.
RETURN TRUE;
END; ! End of q$$match_block
END
ELUDOM