vsiftp.vmssoftware.com/[e-mail]/FREEWARE/FREEWARE40.ZIP/dbs-odsm/interrupt.for

Text File | 1993-11-03 | 5KB | 182 lines

    program interrupt

C+
C Version:    X1-005
C
C Facility:    General Utilities
C
C Abstract:    This program will write a message to a mailbox.
C        Designed for locally written detached processors that use
C        a standard communication interface.
C
C Environment:    VMS V5.0 and later.
C
C    module interrupt_cld
C
C    define verb interrupt
C        qualifier vanilla, nonnegatable
C        qualifier nodefault, nonnegatable
C        qualifier noprefix, nonnegatable
C        parameter p1, label=utility, prompt="whom"
C                ,value (required)
C        parameter p2, label=message, prompt="message"
C                ,value (required, type=$rest_of_line)
C
C History:
C
C    14-Dec-1989, DBS; Version X1-001
C 001 -    Original version.
C    07-Feb-1990, DBS; Version X1-002
C 002 -    Catch a ^Z on the get_foreign prompt and don't let cli ask again.
C    26-Feb-1990, DBS; Version X1-003
C 003 -    Fix missing argument to lib$signal() call.
C    12-Jul-1990, DBS; Version X1-004
C 004 -    Prefixed the message with a char(130) to make it more difficult to
C    send bogus messages.
C    03-Nov-1993, DBS; Version X1-005
C 005 -    Added a /noprefix qualifier for use with other detached processes
C    and added /vanilla to imply /nodefault and /noprefix (saves typing).
C-

     implicit none

    include '($CLIDEF)/nolist'
    include '($IODEF)/nolist'
    include '($RMSDEF)/nolist'

C External references

    integer*4    cli$dcl_parse
    external    cli$dcl_parse
    integer*4    cli$get_value
    external    cli$get_value
    integer*4    cli$present
    external    cli$present
    external    interrupt_cld
    external    intrupt__nomailbox
    external    intrupt__notdeliv
    external    intrupt__success
    integer*4    lib$get_foreign
    external    lib$get_foreign
    external    lib$get_input
    external    lib$put_output
    external    lib$signal
    external    str_collapse
    integer*4    str_len
    external    str_len
    external    str_uppercase
    integer*4    sys$assign
    external    sys$assign
    integer*4    sys$qiow
    external    sys$qiow

C Type declarations for variables

    integer*4    do, nothing
    integer*4    istatus
    integer*2    mbx_channel
    character    mbx_name*256
    integer*4    mbx_name_len
    integer*4    mbx_status
    character    mbx_suffix*(*)
    parameter    (mbx_suffix = '_MAILBOX')
    integer*2    qio_iosb(4)

    integer*4    cli_status
    character    cli_c_verb*9        /'INTERRUPT'/
    character    cli_c_prompt*7        /'_whom: '/
    character    cli_t_command*256
    integer*4    cli_s_command
    integer*4    cli_nodefault
    character    cli_c_nodefault*9    /'NODEFAULT'/
    integer*4    cli_noprefix
    character    cli_c_noprefix*8    /'NOPREFIX'/
    integer*4    cli_vanilla
    character    cli_c_vanilla*7        /'VANILLA'/
    character    cli_c_utility*7        /'UTILITY'/
    integer*2    cli_s_utility
    character    cli_t_utility*80
    character    cli_c_message*7        /'MESSAGE'/
    integer*2    cli_s_message
    character    cli_t_message*256

C+
C Mainline
C-

    istatus = lib$get_foreign (cli_t_command, cli_c_prompt, cli_s_command)

    if (istatus .eq. rms$_eof) then
        do = nothing
    else
    cli_t_command = cli_c_verb//' '//cli_t_command
    cli_s_command = cli_s_command + len(cli_c_verb) + 1

    call cli$dcl_parse (cli_t_command, interrupt_cld
    1            ,lib$get_input, lib$get_input
    1            ,cli_c_prompt)

    cli_nodefault = cli$present (cli_c_nodefault)
    cli_noprefix  = cli$present (cli_c_noprefix)
    cli_vanilla   = cli$present (cli_c_vanilla)

    if (cli_vanilla) then
        cli_nodefault = cli_vanilla
        cli_noprefix  = cli_vanilla
    endif !(cli_vanilla) then

    call cli$get_value (cli_c_utility, cli_t_utility, cli_s_utility)

    if (cli_s_utility .eq. 0) then
        do = nothing
    else
    call cli$get_value (cli_c_message, cli_t_message, cli_s_message)

    if (cli_s_message .eq. 0) then
        do = nothing
    else
    if (cli_nodefault) then
        mbx_name = cli_t_utility(1:cli_s_utility)
    else
    mbx_name = cli_t_utility(1:cli_s_utility)//mbx_suffix
    endif !(cli_nodefault) then

    call str_collapse (mbx_name, mbx_name)
    call str_uppercase (mbx_name)

    mbx_name_len = str_len (mbx_name)

    mbx_status = sys$assign (%descr(mbx_name(1:mbx_name_len))
    1            ,%ref(mbx_channel),,)

    if (.not. mbx_status) then
        call lib$signal (intrupt__nomailbox
    1            ,%val(1), %descr(mbx_name(1:mbx_name_len))
    1            ,%val(mbx_status))
    else
    if (cli_s_message .ne. 0) then
        if (.not. cli_noprefix) then
          cli_t_message = char(130)//cli_t_message(1:cli_s_message)
          cli_s_message = cli_s_message + 1
        endif !(.not. cli_noprefix) then
        mbx_status = sys$qiow (,%val(mbx_channel)
    1                ,%val(io$_writevblk .or. io$m_now)
    1                ,%ref(qio_iosb(1)),,
    1                ,%ref(cli_t_message)
    1                ,%val(cli_s_message),,,,)
        if (.not. mbx_status) then
            call lib$signal (intrupt__notdeliv
    1                ,%val(0)
    1                ,%val(mbx_status))
        else
        call lib$signal (intrupt__success
    1            ,%val(1), %descr(mbx_name(1:mbx_name_len)))
        endif !(.not. mbx_status) then
    endif !(cli_s_message .ne. 0) then
    endif !(.not. mbx_status) then
    endif !(cli_s_message .eq. 0) then
    endif !(cli_s_utility .eq. 0) then
    endif !(istatus .eq. rms$_eof) then

    end