Google
 

Trailing-Edge - PDP-10 Archives - bb-lw55a-bm - language-sources/xpnpmr.b36
There are 21 other files named xpnpmr.b36 in the archive. Click here to see a list.
MODULE xpnpmr (
               %BLISS36 ( ENTRY (XPN$PMR) )
              ) =
BEGIN
!
!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 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:
!   XPN, the Transportable DECNET Interface for BLISS, TOPS-20 version.
!
! ABSTRACT:
!   This module provides poor-man's routing for XPN callers.
!
! ENVIRONMENT:
!   TOPS-20 user mode, XPORT.
!
! AUTHOR: Larry Campbell, CREATION DATE: October 5, 1982
!
! MODIFIED BY:
!
!--

LINKAGE
    tlook_linkage =
        PUSHJ (; REGISTER = 2) :
        LINKAGE_REGS (15, 14, 1);
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
    xpn$pmr,
    init_node_table: NOVALUE,
    tbl_lookup : tlook_linkage,
    tbl_enter : NOVALUE,
    do_pmr,
    negotiate,
    report_error : NOVALUE,
    report_success : NOVALUE;
!
! INCLUDE FILES:
!
LIBRARY 'BLI:XPORT';
LIBRARY 'BLI:MONSYM';
REQUIRE 'JSYSDEF';
LIBRARY 'BLI:TENDEF';
LIBRARY 'BLISSNET';
!
! MACROS:
!
MACRO
    alphanumerics =
        'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789' %;

!
! EQUATED SYMBOLS:
!
$FIELD
    node_block_fields =
        SET
        node_name = [$DESCRIPTOR (DYNAMIC)],
        node_path = [$DESCRIPTOR (DYNAMIC)],
        node_next_block = [$ADDRESS],
        node_real_name = [$ADDRESS],
        node_bits = [$BITS (16)],
            $OVERLAY (node_bits)
            node_synonym = [$BIT]
            $CONTINUE
        TES;

LITERAL
    node_block_length = $FIELD_SET_SIZE,
    maximum_nodes = 1300;
!
! OWN STORAGE:
!
OWN
    term_line_no : INITIAL (0),
    term_iob : $XPO_IOB (),
    node_table : VECTOR [maximum_nodes + 1] INITIAL (0);
!
! EXTERNAL REFERENCES:
!
EXTERNAL ROUTINE
    xpn$errmsg : NOVALUE;
GLOBAL ROUTINE xpn$pmr (p_nlb) = 
!++
! FUNCTIONAL DESCRIPTION:
!   Open a link, using pass-through if necessary.
!   This routine first tries a direct link (does $XPN_OPEN directly).
!   If that fails with "no path", then we look in the node table
!   for a path or paths.  If we find one, we try it.
!
! FORMAL PARAMETERS:
!   p_nlb       - pointer to the NLB for the link
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   NONE
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        nlb = .p_nlb : $XPN_NLB ();

    LOCAL
        original_timeout,
        retcode;
    !
    ! This stuff is valid only for active links, and only for format 0 connects
    !
    IF (NOT .nlb[NLB$V_ACTIVE])
        OR (.nlb[NLB$B_REM_FORMAT] NEQ 0)
    THEN
        RETURN (XPN$_BAD_FLAGS);
    !
    ! First try a direct link.  OPTION = PMR implies OPTION = WAIT.
    !
    original_timeout = .nlb[NLB$B_TIMEOUT];
    IF (retcode = $XPN_OPEN (NLB = nlb, OPTION = WAIT, FAILURE = 0))
    THEN
        RETURN (.retcode);
    !
    ! If the failure was "access not permitted", then there's no point
    ! trying alternate paths.
    !
    IF .retcode EQL XPN$_NO_ACCESS
    THEN
        RETURN (.retcode);
    !
    ! Direct link failed.  Make sure node table is full and try PMR.
    !
    IF .node_table[0] EQL 0
    THEN
        init_node_table ();
    nlb[NLB$B_TIMEOUT] = .original_timeout;
    RETURN (do_pmr (nlb))
    END;                                ! End of xpn$pmr
ROUTINE init_node_table : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!   Parse SYSTEM:DECNET-HOSTS.TXT and fill in our node table.
!   The node table is a TBLUK-style table whose left halves point
!   to node name strings and whose right halves point to node_blocks.
!
! FORMAL PARAMETERS:
!   NONE
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   NONE
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    LOCAL
	node_file : $XPO_IOB (),
        line_scan : $STR_DESCRIPTOR (CLASS = BOUNDED),
        node_descr : $STR_DESCRIPTOR (),
        node_block : REF BLOCK [node_block_length] FIELD (node_block_fields);

    LABEL
        loop;

    $XPO_IOB_INIT (IOB = node_file, FILE_SPEC = 'SYSTEM:DECNET-HOSTS.TXT',
                   OPTIONS = INPUT);
    IF NOT $XPO_OPEN (IOB = node_file)
    THEN
        RETURN;
    node_table[0] = maximum_nodes;
    WHILE $XPO_GET (IOB = node_file)
    DO
loop:   BEGIN
        LOCAL
            char,
            table_index;
        $STR_DESC_INIT (DESCRIPTOR = line_scan, CLASS = BOUNDED,
                        STRING = node_file[IOB$T_STRING]);
        !
        ! Skip leading spaces
        !
        $STR_SCAN (REMAINDER = line_scan, SPAN = ' ',
                   SUBSTRING = line_scan, DELIMITER = char);
        !
        ! Check for comments
        !
        IF (.char EQL %C'!') OR (.char EQL %C';')
        THEN
            LEAVE loop;
        !
        ! OK, this must be a node name, span alphanumerics
        !
        $STR_SCAN (REMAINDER = line_scan, SPAN = alphanumerics,
                   SUBSTRING = line_scan, DELIMITER = char);
        !
        ! If delimiter is not comma or equal-sign, ignore this line
        !
        IF (.char NEQ %C',')    !*** temp ***  AND (.char NEQ %C'=')
        THEN
            LEAVE loop;
        !
        ! Copy the node name
        !
        $STR_DESC_INIT (DESCRIPTOR = node_descr, STRING = line_scan);
        !
        ! Skip the comma
        !
        $STR_SCAN (REMAINDER = line_scan, SPAN = ', ',
                   SUBSTRING = line_scan);
        !
        ! Now span alphanumerics and colons.  This is the path string.
        !
        $STR_SCAN (REMAINDER = line_scan, SPAN = %STRING (alphanumerics, ':'),
                   SUBSTRING = line_scan);
        IF .line_scan[STR$H_LENGTH] EQL 0
        THEN
            LEAVE loop;
        !
        ! Allocate a node block and fill it in.
        !
        $XPO_GET_MEM (FULLWORDS = node_block_length, FILL = 0,
                      RESULT = node_block);
        $STR_DESC_INIT (DESCRIPTOR = node_block[node_name], CLASS = DYNAMIC);
        $STR_DESC_INIT (DESCRIPTOR = node_block[node_path], CLASS = DYNAMIC);
        $STR_COPY (TARGET = node_block[node_name],
                   STRING = node_descr);
        $STR_COPY (TARGET = node_block[node_path],
                   STRING = line_scan);
        !
        ! Now check to see if this node is already in the node table.
        !
        IF tbl_lookup (node_table, node_descr; table_index)
        THEN
            BEGIN
            !
            ! This node already has an entry...  append this node block
            ! to the end of the chain of node blocks
            !
            LOCAL
                blk : REF BLOCK [node_block_length] FIELD (node_block_fields);
            blk = .(.table_index)<0, 18>;
            WHILE .blk[node_next_block] NEQ 0
            DO
                blk = .blk[node_next_block];
            blk[node_next_block] = .node_block;
            END
        ELSE
            !
            ! Not in the table... enter it then
            !
            tbl_enter (node_table, node_descr, .node_block);
        END;                            ! loop
    $XPO_CLOSE (IOB = node_file);
    END;                                ! End of init_node_table
ROUTINE do_pmr (p_nlb) =
!++
! FUNCTIONAL DESCRIPTION:
!   Do poor-man's route-through negotiation for a link.  If we're successful,
!   the link referred to by the NLB is open just as if a direct connection
!   existed.  If any errors occur, we return XPN$_PMR_ERROR.
!
! FORMAL PARAMETERS:
!   p_nlb       - pointer to NLB for link.
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   NONE
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        nlb = .p_nlb : $XPN_NLB (),
        node_name_descr = .nlb[NLB$A_NODE_NAME] : $STR_DESCRIPTOR ();

    LOCAL
	current_node_block : REF BLOCK [node_block_length]
                                 FIELD (node_block_fields);

    IF NOT tbl_lookup (node_table, node_name_descr; current_node_block)
    THEN
        RETURN (XPN$_NOSUCHNODE);
    current_node_block = .(.current_node_block)<0, 18>;
    !
    ! Now, for each possible path, try negotiating a link
    !
    WHILE .current_node_block NEQ 0
    DO
        BEGIN
        LOCAL
            original_timeout,
            retcode;
        original_timeout = .nlb[NLB$B_TIMEOUT];
        !
        ! If we succeed, or fail with access denied, return now
        !
        IF (retcode = negotiate (nlb, current_node_block[node_path]))
            OR (.retcode EQL XPN$_NO_ACCESS)
        THEN
            RETURN (.retcode);
        nlb[NLB$B_TIMEOUT] = .original_timeout;
        current_node_block = .current_node_block[node_next_block];
        END;
    RETURN (XPN$_UNREACH)
    END;                                ! End of xpn$$do_pmr
ROUTINE tbl_enter (p_table, p_descr, datum) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!   Add an entry to a TBLUK-style table.
!
! FORMAL PARAMETERS:
!   p_table             - pointer to table
!   p_descr             - address of descriptor for ID string
!   datum               - datum for entry
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   NONE
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        descr = .p_descr : $STR_DESCRIPTOR (),
        table = .p_table : VECTOR [0];

    LOCAL
        asciz_descr : $STR_DESCRIPTOR (),
        ac2;

    $STR_DESC_INIT (DESCRIPTOR = asciz_descr, CLASS = DYNAMIC);
    $STR_COPY (TARGET = asciz_descr,
               STRING = $STR_CONCAT (descr, %CHAR (0)));
    ac2<18, 18> = .asciz_descr[STR$A_POINTER] + 1;
    ac2< 0, 18> = .datum;
    JSYS_TBADD (table, .ac2)

    END;                                ! End of tbl_enter
ROUTINE tbl_lookup (p_table, p_descr; index) : tlook_linkage =
!++
! FUNCTIONAL DESCRIPTION:
!   Look an entry up in a TBLUK-style table.
!
! FORMAL PARAMETERS:
!   NONE
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   0           - failure, entry not found
!   1           - success, index gets index into table
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        table = .p_table : VECTOR [0],
        descr = .p_descr : $STR_DESCRIPTOR ();

    LOCAL
        asciz_descr : $STR_DESCRIPTOR (),
        asciz_buff : VECTOR [CH$ALLOCATION (40)],
        bits : MONWORD;

    $STR_DESC_INIT (DESCRIPTOR = asciz_descr,
                    STRING = (40, CH$PTR (asciz_buff)));
    $STR_COPY (TARGET = asciz_descr,
               STRING = $STR_CONCAT (descr, %CHAR (0)));
    IF NOT JSYS_TBLUK (table, .asciz_descr[STR$A_POINTER]; index, bits)
    THEN
        RETURN (0);
    IF .bits[TL_EXM]
    THEN
        RETURN (1)
    ELSE
        RETURN (0)

    END;                                ! End of tbl_lookup
ROUTINE negotiate (p_nlb, p_path_descr) =
!++
! FUNCTIONAL DESCRIPTION:
!   Negotiate a poor-man's routing link.
!
! FORMAL PARAMETERS:
!   p_nlb               - pointer to the NLB
!   p_path_descr        - pointer to descriptor for path string of the
!                         form:  "NODE1::NODE2::NODE3::"
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   Success:
!        XPN$_NORMAL            - link successfully negotiated
!   Failure:
!        XPN$_PMR_ERROR         - any failure
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        nlb = .p_nlb : $XPN_NLB (),
        path_descr = .p_path_descr : $STR_DESCRIPTOR ();

    LOCAL
        path_scan : $STR_DESCRIPTOR (CLASS = BOUNDED),
        real_node_name,
        real_object,
        real_username,
        real_password,
        real_account,
        first_node_descr : $STR_DESCRIPTOR (),
        empty : $STR_DESCRIPTOR (),
        optional_data_descr : $XPN_DESCRIPTOR (),
        optional_data : VECTOR [CH$ALLOCATION (2)],
        retcode,
        length,
        pointer;

    $STR_DESC_INIT (DESCRIPTOR = path_scan, STRING = path_descr,
                    CLASS = BOUNDED);
    $STR_DESC_INIT (DESCRIPTOR = empty, STRING = (0, 0));
    !
    ! Preserve the "real" node name and access info period for later
    !
    real_node_name = .nlb[NLB$A_NODE_NAME];
    real_object = .nlb[NLB$B_REM_OBJTYP];
    real_username = .nlb[NLB$A_USER_ID];
    real_password = .nlb[NLB$A_PASSWORD];
    real_account = .nlb[NLB$A_ACCOUNT];
    !
    ! Scan off the first node name in the path
    !
    $STR_SCAN (REMAINDER = path_scan, STOP = ':',
               SUBSTRING = path_scan);
    $STR_DESC_INIT (DESCRIPTOR = first_node_descr, CLASS = FIXED,
                    STRING = path_scan);
    !
    ! Point the NLB to that node name, zero access info, set PMR object type
    !
    nlb[NLB$A_NODE_NAME] = first_node_descr;
    nlb[NLB$A_ACCOUNT] = 0;
    nlb[NLB$A_PASSWORD] = 0;
    nlb[NLB$A_USER_ID] = 0;
    nlb[NLB$B_REM_OBJTYP] = XPN$K_PASS_THROUGH;
    !
    ! If we have a buffer request, build an optional data message for
    ! PMR's benefit.  Note that we have to build it backwards, for
    ! the little-endians (cf. "Gulliver's Travels", by Jonathan Swift)
    !
    IF .nlb[NLB$H_RECEIVE_MAX] NEQ 0
    THEN
        BEGIN
        optional_data<28, 8> = .nlb[NLB$H_RECEIVE_MAX];
        optional_data<20, 8> = .nlb[NLB$H_RECEIVE_MAX] ^ -8;
        $XPN_DESC_INIT (DESCRIPTOR = optional_data_descr,
                        BINARY_DATA = (2, optional_data))
        END
    ELSE
        $XPN_DESC_INIT (DESCRIPTOR = optional_data_descr,
                        BINARY_DATA = (0, 0));
    !
    ! Now do a waiting open... if this fails, restore stuff and quit.
    !
    IF NOT (retcode = $XPN_OPEN (NLB = nlb, FAILURE = 0,
                                 STRING = optional_data_descr,
                                 OPTION = WAIT))
    THEN
        BEGIN
        report_error (nlb, path_descr);
        nlb[NLB$A_NODE_NAME] = .real_node_name;
        nlb[NLB$B_REM_OBJTYP] = .real_object;
        nlb[NLB$A_USER_ID] = .real_username;
        nlb[NLB$A_PASSWORD] = .real_password;
        nlb[NLB$A_ACCOUNT] = .real_account;
        RETURN (.retcode)
        END;
    !
    ! OK, copy actual link info back into NLB
    !
    nlb[NLB$A_NODE_NAME] = .real_node_name;
    nlb[NLB$B_REM_OBJTYP] = .real_object;
    nlb[NLB$A_USER_ID] = .real_username;
    nlb[NLB$A_PASSWORD] = .real_password;
    nlb[NLB$A_ACCOUNT] = .real_account;
    !
    ! We now have an open link to the 1st node in the chain.  Skip
    ! the colons after the node name and send the remainder string over
    ! the link.  We contract the string by 2 to remove the last double colon.
    !
    $STR_SCAN (REMAINDER = path_scan, SPAN = ':',
               SUBSTRING = path_scan);
    length = .path_scan[STR$H_MAXLEN]
             - (.path_scan[STR$H_PFXLEN] + .path_scan[STR$H_LENGTH] + 2);
    pointer = CH$PLUS (.path_scan[STR$A_POINTER], .path_scan[STR$H_LENGTH]);
    !
    ! Make valid descriptors for access info -- if zero, empty descriptor
    !
    IF .real_username EQL 0 THEN real_username = empty;
    IF .real_password EQL 0 THEN real_password = empty;
    IF .real_account EQL 0 THEN real_account = empty;
    !
    ! Send the path string, accounting info, and object type info
    !
    $XPN_PUT (NLB = nlb, TYPE = DATA, OPTION = END_OF_MESSAGE, FAILURE = 0,
              STRING = $STR_CONCAT (%CHAR (1),
                                    (.length, .pointer),
                                    '"',
                                    .real_username,
                                    ' ',
                                    .real_password,
                                    ' ',
                                    .real_account,
                                    '"::"',
                                    $STR_ASCII (.real_object),
                                    '="'));
    !
    ! Post a read and wait for the data
    !
    IF (retcode = $XPN_GET (NLB = nlb, TYPE = DATA, FAILURE = 0))
    THEN
        retcode = $XPN_EVENT_INFO (NLB = nlb, FAILURE = 0, OPTION = WAIT);
    IF .retcode NEQ XPN$_DATA
    THEN
        BEGIN
        nlb[NLB$G_COMP_CODE] = .retcode;        ! For error reporting
        report_error (nlb, path_descr);
        RETURN (.retcode)
        END;
    !
    ! The first byte of the message contains the success/fail code
    !
    IF (.nlb[NLB$H_STRING] LEQ 0)
        OR
        (NOT CH$RCHAR (.nlb[NLB$A_STRING]))
    THEN
        BEGIN
        LOCAL
            error_code,
            error_str : $STR_DESCRIPTOR ();
        !
        ! If we find certain strings which we "know" mean access denied
        ! in the error message, we return XPN$_NO_ACCESS rather than
        ! XPN$_PMR_ERROR, in order to prevent spoolers from requeuing.
        ! First we make a copy of the string so XPORT likes it (the NLB
        ! copy is a binary descriptor, not a string descriptor)
        !
        $STR_DESC_INIT (DESCRIPTOR = error_str, CLASS = DYNAMIC);
        $XPO_GET_MEM (DESCRIPTOR = error_str,
                      CHARACTERS = .nlb[NLB$H_STRING]);
        CH$MOVE (.nlb[NLB$H_STRING],
                 .nlb[NLB$A_STRING],
                 .error_str[STR$A_POINTER]);
        error_code =
            (IF ($STR_SCAN (STRING = error_str,
                           FIND = 'Login information invalid at remote node')
                 OR $STR_SCAN (STRING = error_str,
                               FIND = 'Access not permitted'))
             THEN
                 XPN$_NO_ACCESS
             ELSE
                 XPN$_PMR_ERROR);
        $XPO_FREE_MEM (STRING = error_str);
        report_error (nlb, path_descr);
        $XPN_DISCONNECT (NLB = nlb, TYPE = ABORT, FAILURE = 0);
        $XPN_CLOSE (NLB = nlb, FAILURE = 0);
        RETURN (.error_code)
        END;
    report_success (path_descr);        ! Report success if we have terminal
    RETURN (XPN$_NORMAL)                ! Return success
    END;                                ! End of negotiate
ROUTINE report_error (p_nlb, p_path_descr) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!   Report failure of a PMR path
!
! FORMAL PARAMETERS:
!   p_nlb               - pointer to the NLB
!   p_path_descr        - pointer to descriptor for path string of the
!                         form:  "NODE1::NODE2::NODE3::"
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   Success:
!        XPN$_NORMAL            - link successfully negotiated
!   Failure:
!        XPN$_PMR_ERROR         - any failure
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        nlb = .p_nlb : $XPN_NLB (),
        path_descr = .p_path_descr : $STR_DESCRIPTOR ();

    LOCAL
        length,
        jobno,
        error_descr : $STR_DESCRIPTOR ();
    !
    ! Get our line number.  If we're detached, quit now.
    !
    IF .term_line_no EQL 0
    THEN
        BEGIN
        JSYS_GJINF (; jobno, , , term_line_no);
        IF (.term_line_no EQL 0)
            OR (.jobno EQL 0)
        THEN
            term_line_no EQL -1;
        $XPO_IOB_INIT (IOB = term_iob);
        END;
    IF .term_line_no EQL -1
    THEN
        RETURN;
    !
    ! Ok, we're running on a real terminal.  Report the error.
    !
    $XPO_OPEN (IOB = term_iob, FILE_SPEC = $XPO_INPUT);
    $STR_DESC_INIT (DESCRIPTOR = error_descr, CLASS = DYNAMIC);
    !
    ! If the NLB points to a received message, it's the error.  If not,
    ! we report nlb[NLB$G_COMP_CODE], because we got an $XPN_OPEN error.
    !
    IF .nlb[NLB$H_STRING] NEQ 0
    THEN
        !
        ! The first byte of the msg is a numeric code.  Skip it.
        !
        $STR_COPY (TARGET = error_descr,
                   STRING = (.nlb[NLB$H_STRING] - 1,
                             CH$PLUS (.nlb[NLB$A_STRING], 1)))
    ELSE
        xpn$errmsg (.nlb[NLB$G_COMP_CODE], error_descr, length, 0);
    $XPO_PUT (IOB = term_iob,
              STRING = $STR_CONCAT ('?PMR error: path "',
                                    path_descr,
                                    '" failed',
                                    %CHAR (13,10),
                                    error_descr));
    $XPO_CLOSE (IOB = term_iob);
    $XPO_FREE_MEM (STRING = error_descr);
    END;                                ! End of report_error
ROUTINE report_success (p_path_descr) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!   Report success of a PMR path
!
! FORMAL PARAMETERS:
!   p_path_descr        - pointer to descriptor for path string of the
!                         form:  "NODE1::NODE2::NODE3::"
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   NONE
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        path_descr = .p_path_descr : $STR_DESCRIPTOR ();

    LOCAL
        jobno;
    !
    ! Get our line number.  If we're detached, quit now.
    !
    IF .term_line_no EQL 0
    THEN
        BEGIN
        JSYS_GJINF (; jobno, , , term_line_no);
        IF (.term_line_no EQL 0)
            OR (.jobno EQL 0)
        THEN
            term_line_no EQL -1;
        $XPO_IOB_INIT (IOB = term_iob);
        END;
    IF .term_line_no EQL -1
    THEN
        RETURN;
    !
    ! Ok, we're running on a real terminal.  Report success.
    !
    $XPO_OPEN (IOB = term_iob, FILE_SPEC = $XPO_INPUT);
    $XPO_PUT (IOB = term_iob,
              STRING = $STR_CONCAT (' (Using path "',
                                    path_descr,
                                    '")'));
    $XPO_CLOSE (IOB = term_iob);
    END;                                ! End of report_error
END                                     ! End of module
ELUDOM