PORTIA@engvax.scg.hac.COM.UUCP (08/14/87)
$ show default
$ check_sum = 70718357
$ write sys$output "Creating 5.FOR"
$ create 5.FOR
$ DECK/DOLLARS="$*$*EOD*$*$"
subroutine print_message( message, abort )
include 'swing.cmn'
logical abort, erased
character message*(*)
if ( using_screen ) then
if ( message .eq. ' ' ) then
if ( .not. erased ) then
erased = .true.
call smg$erase_display( window3 )
call smg$erase_line( window3, 2, 1 )
end if
else
erased = .false.
call smg$erase_display( window3 )
call smg$put_chars( window3, message, 2, 1, 1 )
end if
if ( abort ) call exit_swing
else
print *, 'SWING: ', message
if ( abort ) stop ' '
end if
return
end
subroutine process_command ( out_message, window, stop )
c Craig Young 3-AUG-87
include 'swing.cmn'
include '($syssrvnam)'
include '($ssdef)'
include '($iodef)'
include '($clidef)'
integer window, stop
integer*4 status, done, proc_id, message_len, lib$spawn
integer*4 str$position
character in_message*100, out_message*100, terminator*50
character set_noon*8/'set noon'/
parameter
- (terminator = 'swing dcl subprocess command output terminator')
message_len = 100
if ( proc_created .eq. 0 ) then
status = sys$crembx ( ,outbox_channel ,,,,,'swing_dcl_inbox')
if ( status .ne. ss$_normal ) call exit(status)
status = sys$crembx ( ,inbox_channel ,,,,,'swing_dcl_outbox')
if ( status .ne. ss$_normal ) call exit(status)
status = lib$spawn ( ,'swing_dcl_inbox' ,'swing_dcl_outbox'
- ,cli$m_nowait ,,proc_id
- ,,done )
if (status .ne. ss$_normal) call exit(status)
status = sys$qiow( ,%val(outbox_channel)
- ,%val(io$_writevblk) ,
- ,,,%ref(set_noon)
- ,%val(len(set_noon)) ,,,, )
if ( status .ne. ss$_normal ) call exit(status)
proc_created = 1
end if
status = sys$qiow( ,%val(outbox_channel)
- ,%val(io$_writevblk) ,
- ,,,%ref(out_message)
- ,%val(message_len) ,,,, )
if ( status .ne. ss$_normal ) call exit(status)
if ( stop .eq. 0 ) then
out_message = 'write sys$output "'//terminator//'"'
status = sys$qio ( ,%val(outbox_channel)
- ,%val(io$_writevblk) ,
- ,,,%ref(out_message)
- ,%val(message_len) ,,,, )
if ( status .ne. ss$_normal ) call exit(status)
in_message = ' '
status = 0
do while ( in_message .ne. terminator )
if ( window .eq. DCL_window ) then
call smg$put_line( window, in_message )
else
if ( in_message .ne. ' ' ) then
call print_message( in_message, 0 )
end if
end if
in_message = ' '
status = sys$qiow( ,%val(inbox_channel)
- ,%val(io$_readvblk) ,
- ,,,%ref(in_message)
- ,%val(message_len) ,,,, )
if ( status .ne. ss$_normal ) call exit(status)
end do
end if
return
end
subroutine record_structure( search )
include 'swing.cmn'
character spec*255
logical search, modify_file_prot
integer icontext, ii, jj, istat, len_spec
integer lib$find_file, lib$delete_file
if ( search .and. swing_file_exists ) then
do ii = 1, num_nodes
node(ii).length = 0
node(ii).child = 0
node(ii).sister = 0
end do
call load_nodes
call load_display
call update_screen( cur_line, cur_level )
end if
do_save = .false.
call print_message( 'Saving directory structure', 0 )
icontext = 0
do while( lib$find_file( main(1:len_main)//'swing.sav;*',
. spec, icontext ))
if ( .not. lib$delete_file( spec ) ) then
call str$trim( spec, spec, len_spec )
if ( modify_file_prot( spec(1:len_spec), 0, 0 ) ) then
istat = lib$delete_file( spec )
else
call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
. main(1:len_main)//'swing.sav',
. 'NL:', 'NL:' )
istat = lib$delete_file( spec )
end if
end if
end do
call lib$find_file_end( icontext )
open( unit=2,
. name=main(1:len_main)//'swing.sav',
. status='new',
. carriagecontrol='list',
. access='sequential',
. form='unformatted',
. recl=73,
. organization='sequential',
. recordtype='variable',
. iostat=istat,
. err=99 )
write( 2 ) num_lines, num_nodes, lowest_level
do ii = 1, num_lines
write( 2 ) (node_pointer(jj,ii), jj=0, MAX_LEVELS)
end do
do ii = 1, num_nodes
write( 2 ) node(ii)
end do
close( unit=2 )
swing_file_exists = .true.
call print_message( 'Finished saving directory structure', 0 )
return
99 call print_message( 'Unable to record directory structure', 0 )
return
end
subroutine redefine_smg_layout
c Craig Young 3-AUG-87
c This subroutine redefines the options for the command bar.
include 'swing.cmn'
include '($smgdef)'
record /pd_choice_type/ sub_choices(8)
pull_choices.number = 8
pull_choices.choice(1) = 'Delete'
pull_choices.code(1) = 110
pull_choices.ptr(1) = 0
pull_choices.choice(2) = 'Edit'
pull_choices.code(2) = 120
pull_choices.ptr(2) = 0
pull_choices.choice(3) = 'Move'
pull_choices.code(3) = 130
pull_choices.ptr(3) = 0
pull_choices.choice(4) = 'Options'
pull_choices.code(4) = 140
pull_choices.ptr(4) = %loc( sub_choices(4) )
pull_choices.choice(5) = 'Print'
pull_choices.code(5) = 150
pull_choices.ptr(5) = 0
pull_choices.choice(6) = 'Rename'
pull_choices.code(6) = 160
pull_choices.ptr(6) = 0
pull_choices.choice(7) = 'Help'
pull_choices.code(7) = 170
pull_choices.ptr(7) = 0
pull_choices.choice(8) = 'Quit'
pull_choices.code(8) = 180
pull_choices.ptr(8) = %loc( sub_choices(8) )
sub_choices(4).number = 1
sub_choices(4).choice(1) = 'DCL Command'
sub_choices(4).code(1) = 141
sub_choices(8).number = 2
sub_choices(8).choice(1) = 'Okay, quit filer'
sub_choices(8).code(1) = 181
sub_choices(8).choice(2) = 'Cancel'
sub_choices(8).code(2) = 182
call pd_load_bar( width, pull_choices )
return
end
subroutine rename_directory( code )
include 'swing.cmn'
include '($ssdef)'
include '($smgdef)'
character new_dir*42, key, string*39, message*255, file*255
integer ikey, len_string, lib$rename_file, code, parent
integer sys$getmsg, istat, len_message, ipos, from_level
integer old_line, old_level, from_num, from_line, ii, jj
logical dir_to_file, finished, check_directory_move
if ( code .eq. 20 ) then
call print_message( ' ', 0 )
call smg$set_cursor_abs( window3, 1, 1 )
call smg$read_string( keyboard, string,
. 'Enter new name to give directory: ',
. 39,,,,len_string,, window3 )
new_dir = ' '
jj = 0
do ii = 1, len_string
if (string(ii:ii) .ne. '[' .and. string(ii:ii) .ne. ']'.and.
. string(ii:ii) .ne. '.' .and. string(ii:ii) .gt. ' ' .and.
. string(ii:ii) .ne. ';' ) then
jj = jj + 1
new_dir(jj:jj) = string(ii:ii)
end if
end do
call str$upcase( new_dir, new_dir )
if ( jj .ne. 0 ) then
if ( dir_to_file( node(node_num).spec,
. node(node_num).length,
. file, ipos ) ) then
istat = lib$rename_file( file,
. new_dir(1:jj)//'.DIR;1',,,
. 1 )
if ( istat .eq. ss$_normal ) then
call file_to_dir( file(1:ipos)//new_dir(1:jj)//'.DIR',
. node(node_num).spec,
. node(node_num).length,
. node(node_num).name )
parent = 0
call move_node( node_num, parent )
call adjust_node_pointers
call load_display
cur_line = node(node_num).line
cur_level = node(node_num).level
call update_screen( cur_line, cur_level )
call print_message( 'Subdirectory renamed', 0 )
do_save = .true.
else
call sys$getmsg( %val(istat), len_message, message,
. %val(1), )
call print_message( message(1:len_message), 0 )
end if
end if
else
call smg$erase_display( window3 )
end if
else if ( code .eq. 30 ) then
from_num = node_num
from_line = cur_line
from_level = cur_level
node(from_num).rend = smg$m_reverse + smg$m_blink
call smg$change_rendition( window2, from_line, from_level*17+1,
. 1, 12, node(from_num).rend )
call print_message( 'Travel to new parent directory and hit '//
. 'RETURN - Hit any other key to abort', 0 )
call smg$set_cursor_abs( window2, from_line, from_level*17+1 )
finished = .false.
do while ( .not. finished )
call smg$read_keystroke( keyboard, ikey )
old_line = cur_line
old_level = cur_level
old_rend = node(node_num).rend
if ( ikey .eq. smg$k_trm_cr .or.
. ikey .eq. smg$k_trm_enter ) then
finished = .true.
else if ( ikey .eq. smg$k_trm_up ) then
ii = cur_level
jj = cur_line - 1
do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 )
jj = jj - 1
end do
if ( jj .ge. 1 ) cur_line = jj
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_down ) then
ii = cur_level
jj = cur_line + 1
do while( node_pointer(ii,jj) .eq. 0 .and.
. jj .le. num_lines )
jj = jj + 1
end do
if ( jj .le. num_lines ) cur_line = jj
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_right ) then
ii = cur_level + 1
jj = cur_line
do while( node_pointer(ii,jj) .eq. 0 .and.
. ii .le. MAX_LEVELS )
ii = ii + 1
end do
if ( ii .le. MAX_LEVELS ) cur_level = ii
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_left .and.
. cur_level .ge. 1 ) then
ii = cur_level - 1
jj = cur_line
do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 )
jj = jj - 1
end do
if ( jj .ge. 1 ) then
cur_level = ii
cur_line = jj
end if
call update_screen( old_line, old_level )
else
finished = .true.
end if
call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )
end do
node(from_num).rend = smg$m_reverse
call smg$change_rendition( window2, from_line, from_level*17+1,
. 1, 12, node(from_num).rend )
if ( ikey .eq. smg$k_trm_cr .or.
. ikey .eq. smg$k_trm_enter ) then
if ( .not. check_directory_move( from_num, node_num ) ) then
call update_screen( cur_line, cur_level )
call print_message( 'Rename would cause too great a '//
. 'directory depth', 0 )
return
end if
if ( dir_to_file( node(from_num).spec,
. node(from_num).length,
. file, ipos ) ) then
istat = lib$rename_file( file,
. node(node_num).spec(1:node(node_num).length)//
. '*.dir;1',,, 1 )
if ( istat ) then
call move_node( from_num, node_num )
call adjust_node_pointers
call load_display
cur_line = node(from_num).line
cur_level = node(from_num).level
call update_screen( cur_line, cur_level )
call print_message( 'Subdirectory has been moved', 0 )
do_save = .true.
else
call sys$getmsg( %val(istat), len_message, message,
. %val(1), )
call print_message( message(1:len_message), 0 )
end if
end if
else
call smg$erase_display( window3 )
end if
else
call smg$erase_display( window3 )
end if
return
end
subroutine rename_file
c Craig Young 3-AUG-87
c This subroutine prompts the user for a new name for the current file.
include 'swing.cmn'
integer istat, len_string, len_message, lib$rename_file
character string*100, message*255
c Check if current file is a directory. If so, abort rename.
istat = index( fnode(file_num).spec(1:), '.DIR;1' )
if ( istat .eq. 0 ) then
call print_message( ' ', 0 )
call smg$set_cursor_abs( window3, 2, 1 )
call smg$read_string( keyboard, string, 'New name: ',
. ,,,,len_string,, window3 )
call str$upcase( string, string )
istat = lib$rename_file( fnode(file_num).spec, string )
if ( istat ) then
call print_message( 'File has been renamed.', 0 )
else
call sys$getmsg( %val(istat), len_message, message,
. %val(1), )
call print_message( message(1:len_message), 0 )
end if
call load_files
call update_file_window
else
call print_message('Cannot rename directory with the filer.',0)
end if
return
end
subroutine reset_terminal( terminal, char_buffer )
implicit none
C ROUTINE USES THE IO$_SETMODE FUNCTION TO SET TERMINAL
C CHARACTERISTICS
include '($iodef)'
c LAYOUT OF char_buffer
c
c --------------------------------------------
c | buffer size | type | class | <- longword
c |page len | terminal characteristics | <- longword (TTDEF)
c | extended terminal characteristics | <- longword (TT2DEF)
c --------------------------------------------
c 31 0
integer*2 iosb(4)
integer*4 status, sys$trnlog, sys$assign, sys$qiow, chan
integer*4 reset, char_buffer(3)
character terminal*(*)
status = sys$assign( terminal, chan,, )
status = sys$qiow ( %val(1),
. %val(chan),
. %val(io$_setmode),
. iosb,,,
. %ref(char_buffer),
. %val(12),,,, )
return
end
subroutine set_notab( terminal, save_buffer )
implicit none
C ROUTINE USES THE IO$_SETMODE FUNCTION TO SET TERMINAL
C CHARACTERISTICS
include '($iodef)'
include '($ttdef)'
include '($tt2def)'
c LAYOUT OF char_buffer
c
c --------------------------------------------
c | buffer size | type | class | <- longword
c |page len | terminal characteristics | <- longword (TTDEF)
c | extended terminal characteristics | <- longword (TT2DEF)
c --------------------------------------------
c 31 0
integer*2 iosb(4)
integer*4 status, sys$trnlog, sys$assign, sys$qiow, chan
integer*4 char_buffer(3), save_buffer(3)
character terminal*(*)
status = sys$assign( terminal, chan,, )
status = sys$qiow ( %val(1),
. %val(chan),
. %val(io$_sensemode),
. iosb,,,
. %Ref(save_buffer),
. %val(12),,,, )
char_buffer(1) = save_buffer(1)
char_buffer(2) = jibclr( save_buffer(2), tt$v_mechtab )
char_buffer(3) = save_buffer(3)
status = sys$qiow ( %val(1),
. %val(chan),
. %val(io$_setmode),
. iosb,,,
. %Ref(char_buffer),
. %val(12),,,, )
return
end
subroutine show_files
c Craig Young 3-AUG-87
c This subroutine controls the initialization of the filer window as well
c as movement and command_level input within the filer.
include 'swing.cmn'
include '($smgdef)'
integer ikey, isave, code, code_type, jj
logical finished
character key, choice*(PD_MAX_CHOICE_LEN)
call smg$begin_pasteboard_update( board_id )
call smg$erase_display( file_window )
call smg$label_border( file_window, node(node_num).name )
call smg$paste_virtual_display( file_window, board_id, 10, 40 )
call load_files
call update_file_window
call redefine_smg_layout
call smg$end_pasteboard_update( board_id )
finished = .false.
do while ( .not. finished )
call smg$set_cursor_abs( file_window,
. file_num - top_file_line + 1, 1 )
call smg$read_keystroke( keyboard, ikey )
call print_message( ' ', 0 )
if ( ikey .eq. smg$k_trm_do .or.
. ikey .eq. smg$k_trm_ctrlp ) then
call pd_get_choice( board_id, keyboard, width,
. pull_choices, choice, code )
code_type = code / 10
else
code_type = 0
code = 0
end if
if ( ikey .eq. smg$k_trm_enter .or.
. ikey .eq. smg$k_trm_lowercase_q .or.
. ikey .eq. smg$k_trm_uppercase_q .or.
. code .eq. 181 ) then
finished = .true.
else if ( ikey .eq. smg$k_trm_up ) then
jj = file_num - 1
if ( jj .ge. 1 ) file_num = jj
call update_file_window
else if ( ikey .eq. smg$k_trm_down ) then
jj = file_num + 1
if ( jj .le. num_files ) file_num = jj
call update_file_window
else if ( code .eq. 111 .or.
. ikey .eq. smg$k_trm_lowercase_d .or.
. ikey .eq. smg$k_trm_uppercase_d ) then
call delete_file
else if ( code_type .eq. 12 .or.
. ikey .eq. smg$k_trm_lowercase_e .or.
. ikey .eq. smg$k_trm_uppercase_e ) then
call edit_file
else if ( code_type .eq. 13 .or.
. ikey .eq. smg$k_trm_lowercase_m .or.
. ikey .eq. smg$k_trm_uppercase_m ) then
call move_file
else if ( code_type .eq. 14 .or.
. ikey .eq. smg$k_trm_lowercase_o .or.
. ikey .eq. smg$k_trm_uppercase_o ) then
call file_options( code )
else if ( code_type .eq. 15 .or.
. ikey .eq. smg$k_trm_lowercase_p .or.
. ikey .eq. smg$k_trm_uppercase_p ) then
call print_file
else if ( code_type .eq. 16 .or.
. ikey .eq. smg$k_trm_lowercase_r .or.
. ikey .eq. smg$k_trm_uppercase_r ) then
call rename_file
else if ( code_type .eq. 17 .or.
. ikey .eq. smg$k_trm_lowercase_h .or.
. ikey .eq. smg$k_trm_uppercase_h ) then
call help_filer
end if
end do
call smg$begin_pasteboard_update( board_id )
call smg$unpaste_virtual_display( file_window, board_id )
call define_smg_layout
call smg$end_pasteboard_update( board_id )
return
end
subroutine sm_allow_repaint
include 'swing.cmn'
integer address
external sm_repaint_screen
address = %loc( sm_repaint_screen )
call smg$set_out_of_band_asts( board_id, '800000'x,
. %val(address) )
return
end
subroutine sm_repaint_screen
include 'swing.cmn'
call smg$repaint_screen( board_id )
return
end
*=======================================================================
*
* Title: SWING
*
* Version: 1-001
*
* Abstract: SWING is a VMS utility for displaying and manipulating
* VMS directory trees.
*
* Environment: VMS
*
* Author: Eric Andresen of General Research Corporation
*
* Date: 24-SEP-1986
*
*-----------------------------------------------------------------------
*
* Modified and
* Expanded by: Craig Young of Hughes Aircraft Company
*
* Additions: The main addition was the FILER and all the subroutines
* which support it. The DCL Command option was added to
* the SWING command menu. Changes were made to subroutine
* Load_Nodes to support '<' and '>' as directory indica-
* tors, to allow the Master file directory as the root
* directory and to allow the START qualifier.
*
* Date: 3-AUG-1987
*
*-----------------------------------------------------------------------
program swing
include 'swing.cmn'
include '($smgdef)'
integer ii, jj, istat
integer ikey, old_level, old_line, isave, code, code_type
integer smg$create_virtual_display
logical crt, finished
character key, choice*(PD_MAX_CHOICE_LEN)
if ( .not. crt() )
. call print_message( 'You must use a DEC CRT terminal', 1 )
call define_paste_board
c CREATE THE WINDOWS
istat = smg$create_virtual_display( 1, 132, window1 )
istat = smg$create_virtual_display( MAX_LINES, 132, window2 )
istat = smg$create_virtual_display( 2, 132, window3 )
istat = smg$create_virtual_display( 12, 25, file_window )
call smg$set_display_scroll_region( file_window )
istat = smg$create_virtual_display( 15, 70, DCL_window )
call smg$set_display_scroll_region( DCL_window )
call load_nodes
call define_smg_layout
call load_display
call draw_screen
proc_created = 0
do while ( .not. finished )
call smg$read_keystroke( keyboard, ikey )
call print_message( ' ', 0 )
old_line = cur_line
old_level = cur_level
old_rend = node(node_num).rend
code_type = 0
code = 0
if ( ikey .eq. smg$k_trm_do .or.
. ikey .eq. smg$k_trm_ctrlp ) then
if ( avo ) then
call pd_get_choice( board_id, keyboard, width,
. pull_choices, choice, code )
code_type = code / 10
else
call print_message( 'Advanced video option required', 0 )
end if
end if
if ( ikey .eq. smg$k_trm_ctrlz .or.
. ikey .eq. smg$k_trm_lowercase_x .or.
. ikey .eq. smg$k_trm_uppercase_x .or.
. ikey .eq. smg$k_trm_lowercase_e .or.
. ikey .eq. smg$k_trm_uppercase_e .or.
. ikey .eq. smg$k_trm_enter .or.
. code .eq. 91 ) then
finished = .true.
else if ( ikey .eq. smg$k_trm_up ) then
ii = cur_level
jj = cur_line - 1
do while( jj .ge. 1 .and. node_pointer(ii,jj) .eq. 0 )
jj = jj - 1
end do
if ( jj .ge. 1 ) cur_line = jj
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_down ) then
ii = cur_level
jj = cur_line + 1
do while( node_pointer(ii,jj) .eq. 0 .and.jj .le. num_lines)
jj = jj + 1
end do
if ( jj .le. num_lines ) cur_line = jj
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_right ) then
ii = cur_level + 1
jj = cur_line
do while( node_pointer(ii,jj) .eq. 0 .and.ii.le. MAX_LEVELS)
ii = ii + 1
end do
if ( ii .le. MAX_LEVELS ) cur_level = ii
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_left .and.
. cur_level .ge. 1 ) then
ii = cur_level - 1
jj = cur_line
do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 )
jj = jj - 1
end do
if ( jj .ge. 1 ) then
cur_level = ii
cur_line = jj
end if
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_lowercase_b .or.
. ikey .eq. smg$k_trm_uppercase_b ) then
ii = MAX_LEVELS
cur_line = num_lines
do while( node_pointer(ii,cur_line) .eq. 0 .and. ii .ge. 1 )
ii = ii - 1
end do
cur_level = ii
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_lowercase_t .or.
. ikey .eq. smg$k_trm_uppercase_t ) then
cur_line = 1
cur_level = 0
call update_screen( old_line, old_level )
else if ( code_type .eq. 1 .or.
. ikey .eq. smg$k_trm_lowercase_c .or.
. ikey .eq. smg$k_trm_uppercase_c ) then
call create_directory( code )
else if ( code_type .eq. 2 .or.
. ikey .eq. smg$k_trm_lowercase_r .or.
. ikey .eq. smg$k_trm_uppercase_r ) then
call rename_directory( 20 )
else if ( code_type .eq. 3 .or.
. ikey .eq. smg$k_trm_lowercase_m .or.
. ikey .eq. smg$k_trm_uppercase_m ) then
call rename_directory( 30 )
else if ( code_type .eq. 4 .or.
. ikey .eq. smg$k_trm_lowercase_d .or.
. ikey .eq. smg$k_trm_uppercase_d ) then
call delete_directory( code )
else if ( code_type .eq. 5 .or.
. ikey .eq. smg$k_trm_lowercase_p .or.
. ikey .eq. smg$k_trm_uppercase_p ) then
call hardcopy( code )
else if ( code_type .eq. 6 .or.
. ikey .eq. smg$k_trm_lowercase_s .or.
. ikey .eq. smg$k_trm_uppercase_s ) then
call record_structure( .true. )
else if ( code_type .eq. 7 .or.
. ikey .eq. smg$k_trm_lowercase_o .or.
. ikey .eq. smg$k_trm_uppercase_o ) then
call change_options( code )
else if ( code_type .eq. 8 .or.
. ikey .eq. smg$k_trm_pf2 .or.
. ikey .eq. smg$k_trm_help .or.
. ikey .eq. smg$k_trm_lowercase_h .or.
. ikey .eq. smg$k_trm_uppercase_h ) then
call help( code )
end if
call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )
end do
call exit_swing
end
function translate_logical (logical_name,translation)
c Craig Young 3-AUG-87
implicit none
include '($lnmdef)'
include '($ssdef)'
integer*4 translate_logical
character*(*) translation
character*(*) logical_name
integer*4 sys$trnlnm
integer*4 status
integer*4 attribute
integer*4 ret_buf_len
integer*4 n
structure /item_list/
integer*2 item_len
integer*2 item_code /lnm$_string/
integer*4 buffer_addr
integer*4 ret_buffer_addr /0/
integer*4 end_items /0/
end structure
record /item_list/ items
translation = ' '
attribute = lnm$m_case_blind
items.item_len = LEN(logical_name)
items.buffer_addr = %loc(translation)
call str$trim(logical_name,logical_name,n)
status = sys$trnlnm ( attribute, 'LNM$PROCESS',
- logical_name(1:n),,items)
if ( status .ne. ss$_normal ) then
status = sys$trnlnm ( attribute, 'LNM$JOB',
- logical_name(1:n),,items)
if ( status .ne. ss$_normal )
- status = sys$trnlnm ( attribute, 'LNM$SYSTEM',
- logical_name(1:n),,items)
end if
translate_logical = status
return
end
subroutine update_file_window
c Craig Young 3-AUG-87
c This subroutine updates the filer window to reflect movement of the
c cursor and scrolling.
include 'swing.cmn'
include '($smgdef)'
integer ii
call smg$begin_pasteboard_update( board_id )
c Check if scrolling required. If so, scroll a half window.
if ( file_num .gt. bottom_file_line ) then !If cursor at bottom
top_file_line = top_file_line + 6 !Scroll up
bottom_file_line = bottom_file_line + 6
else if ( file_num .lt. top_file_line ) then !If cursor at top
top_file_line = top_file_line - 6 !Scroll down
bottom_file_line = bottom_file_line - 6
end if
call smg$set_cursor_abs( file_window, 1, 1 )
do ii = top_file_line, bottom_file_line !Reprint file names
call smg$put_line( file_window, fnode(ii).name )
end do !for new range
call smg$change_rendition( file_window,
. file_num - top_file_line + 1,
. 2, 1, 24, smg$m_reverse )
call smg$end_pasteboard_update( board_id )
return
end
subroutine update_screen( old_line, old_level )
include 'swing.cmn'
include '($smgdef)'
integer old_line, old_level, ii, istat
integer sys$setddir
node_num = node_pointer( cur_level, cur_line )
call smg$begin_pasteboard_update( board_id )
call smg$change_rendition( window2, old_line, old_level*17+1,
. 1, 12, old_rend )
call smg$change_rendition( window2, cur_line, cur_level*17+1,
. 1, 12,
. smg$m_bold + node(node_num).rend )
call update_window1
call smg$end_pasteboard_update( board_id )
if ( cur_line .gt. bottom_line ) then
do ii = bottom_line+1, cur_line
call smg$move_virtual_display( window2, board_id,23-ii,1)
end do
top_line = cur_line - 19
bottom_line = cur_line
else if ( cur_line .lt. top_line ) then
do ii = top_line-1, cur_line, -1
call smg$move_virtual_display( window2, board_id, 4-ii,1)
end do
top_line = cur_line
bottom_line = cur_line + 19
end if
istat = sys$setddir( node(node_num).spec, %val(0), %val(0) )
return
end
subroutine update_window1
include 'swing.cmn'
include '($smgdef)'
integer start
if ( use_window1 ) then
start = ( width - (len_disk + node(node_num).length) ) / 2
if ( start .le. 0 ) start = 1
call smg$erase_line( window1, 1, 1 )
call smg$put_chars( window1,
. disk(1:len_disk)//
. node(node_num).spec(1:node(node_num).length),
. 1, start,, smg$m_underline )
end if
return
end
$*$*EOD*$*$
$ checksum 5.FOR
$ if checksum$checksum .ne. check_sum then -
$ write sys$output "Checksum failed, file probably corrupted"
$ exit