PORTIA@engvax.scg.hac.COM.UUCP (08/14/87)
$ show default
$ check_sum = 846395426
$ write sys$output "Creating 2.FOR"
$ create 2.FOR
$ DECK/DOLLARS="$*$*EOD*$*$"
subroutine add_node( new_dir, parent )
include 'swing.cmn'
character new_dir*42, spec*255
integer parent, len, new_node, free_node, ii, jj
logical greater
call str$trim( new_dir, new_dir, len )
spec = node(parent).spec(1:node(parent).length)//
. new_dir(1:len)//'.DIR;1'
new_node = free_node()
call file_to_dir( spec,
. node(new_node).spec,
. node(new_node).length,
. node(new_node).name )
if ( node(parent).child .eq. 0 ) then
node(parent).child = new_node
else
ii = node(parent).child
if ( node(new_node).name .lt. node(ii).name ) then
node(new_node).sister = node(parent).child
node(parent).child = new_node
else
greater = .true.
do while ( greater )
if ( node(ii).sister .eq. 0 ) then
node(ii).sister = new_node
greater = .false.
else
jj = ii
ii = node(ii).sister
if ( node(new_node).name .lt. node(ii).name ) then
node(jj).sister = new_node
node(new_node).sister = ii
greater = .false.
end if
end if
end do
end if
end if
return
end
subroutine add_node_to_display( num )
include 'swing.cmn'
include '($smgdef)'
integer column, num, level
node(num).rend = smg$m_reverse
level = node(num).level
column = level * 17 + 1
line = node(num).line
call smg$put_chars( window2, node(num).name, line, column,,
. node(num).rend )
call smg$draw_line( window2, line, column-3, line, column-1 )
if ( level .eq. last_level ) then
call smg$draw_line( window2, line-1, column-3, line, column-3 )
else if ( level .eq. last_level + 1 ) then
call smg$draw_line( window2, line, column-5, line, column-2 )
else if ( level .lt. last_level ) then
call smg$draw_line( window2, last_line(level), column-3,
. line, column-3 )
end if
if ( .not. found .and. root(2:len_root-1)
. .eq. node(num).spec(2:node(num).length-1) ) then
found = .true.
cur_line = line
cur_level = level
end if
last_level = level
last_line(level) = line
return
end
subroutine adjust_node_pointers
include 'swing.cmn'
include '($smgdef)'
integer ll, jj, ptr(0:7), ii
do ll = 1, MAX_LINES
do jj = 0, MAX_LEVELS
node_pointer(jj,ll) = 0
end do
end do
do jj = 0, MAX_LEVELS
ptr(jj) = 0
end do
ll = 1 !LINE
ptr(0) = 1
node_pointer(0,ll) = 1
ptr(1) = node(ptr(0)).child
do while( ptr(1) .ne. 0 )
node_pointer(1,ll) = ptr(1)
node(ptr(1)).line = ll
node(ptr(1)).level = 1
ptr(2) = node(ptr(1)).child
do while( ptr(2) .ne. 0 )
node_pointer(2,ll) = ptr(2)
node(ptr(2)).line = ll
node(ptr(2)).level = 2
ptr(3) = node(ptr(2)).child
do while( ptr(3) .ne. 0 )
node_pointer(3,ll) = ptr(3)
node(ptr(3)).line = ll
node(ptr(3)).level = 3
ptr(4) = node(ptr(3)).child
do while( ptr(4) .ne. 0 )
node_pointer(4,ll) = ptr(4)
node(ptr(4)).line = ll
node(ptr(4)).level = 4
ptr(5) = node(ptr(4)).child
do while( ptr(5) .ne. 0 )
node_pointer(5,ll) = ptr(5)
node(ptr(5)).line = ll
node(ptr(5)).level = 5
ptr(6) = node(ptr(5)).child
do while( ptr(6) .ne. 0 )
node_pointer(6,ll) = ptr(6)
node(ptr(6)).line = ll
node(ptr(6)).level = 6
ptr(7) = node(ptr(6)).child
do while( ptr(7) .ne. 0 )
node_pointer(7,ll) = ptr(7)
node(ptr(7)).line = ll
node(ptr(7)).level = 7
ptr(7) = node(ptr(7)).sister
if ( ptr(7) .ne. 0 ) ll = ll + 1
end do
ptr(6) = node(ptr(6)).sister
if ( ptr(6) .ne. 0 ) ll = ll + 1
end do
ptr(5) = node(ptr(5)).sister
if ( ptr(5) .ne. 0 ) ll = ll + 1
end do
ptr(4) = node(ptr(4)).sister
if ( ptr(4) .ne. 0 ) ll = ll + 1
end do
ptr(3) = node(ptr(3)).sister
if ( ptr(3) .ne. 0 ) ll = ll + 1
end do
ptr(2) = node(ptr(2)).sister
if ( ptr(2) .ne. 0 ) ll = ll + 1
end do
ptr(1) = node(ptr(1)).sister
if ( ptr(1) .ne. 0 ) ll = ll + 1
end do
lowest_level = 0
do ii = 1, num_nodes
if ( node(ii).level .gt. lowest_level )
. lowest_level = node(ii).level
end do
c if ( lowest_level .gt. 7 ) then
c call print_message( 'Directory nesting is to deep', 1 )
c end if
num_lines = ll
return
end
subroutine append_fnode( spec )
c Craig Young 3-AUG-87
c This subroutine adds a file name to the FNode array, truncating, if
c necessary, the file spec into a 20-character name.
include 'swing.cmn'
integer len_node, ii
character specout*255, spec*255
num_files = num_files + 1
file_num = num_files
ii = 1
do while ( spec(ii:ii) .ne. ']' .and. spec(ii:ii) .ne. '>' )
ii = ii + 1
end do
call str$trim( specout, spec, len_node )
fnode(file_num).spec = specout
fnode(file_num).length = len_node - ii
if ( fnode(file_num).length .le. 23 ) then
fnode(file_num).name = specout(ii+1:)
else
fnode(file_num).name = specout(ii+1:ii+22)//'*'
end if
return
end
subroutine append_node( level, spec, search )
include 'swing.cmn'
include '($smgdef)'
integer level, len_node, free_node, istat
character spec*255, search*255
node_num = free_node()
if ( level .gt. lowest_level ) lowest_level = level
if ( level .le. last_level ) then
line = line + 1
num_lines = line
node(last_node(level)).sister = node_num
else
node(node_num-1).child = node_num
end if
if ( level .ne. 0 ) then
call file_to_dir( spec,
. node(node_num).spec,
. node(node_num).length,
. node(node_num).name )
else
call str$trim( spec, spec, len_node )
node(node_num).spec = spec
node(node_num).length = len_node
if ( len_node .le. 10 ) then
node(node_num).name = spec
else
node(node_num).name = spec(:11)//'*'
end if
end if
node(node_num).line = line
node(node_num).level = level
node(node_num).rend = smg$m_reverse
node_pointer(level,line) = node_num
search = node(node_num).spec(1:node(node_num).length)//'*.dir;1'
last_level = level
last_node(level) = node_num
return
end
subroutine change_options( code )
include 'swing.cmn'
character choice*(pd_max_choice_len)
integer code
logical do_bar
logical temp
if ( code .eq. 0 ) then
call pd_list_choice( board_id, keyboard, width, 7,
. %val(pull_choices.ptr(7)),
. choice, code, do_bar )
end if
if ( code .eq. 71 ) then
call execute_dcl
else if ( code .eq. 72 ) then
use_window1 = .not. use_window1
if ( .not. use_window1 ) then
call smg$erase_display( window1 )
else
call update_window1
end if
else if ( code .eq. 73 ) then
temp = use_window1
call show_files
use_window1 = temp
end if
return
end
subroutine change_spec( parent, ptr )
include 'swing.cmn'
character spec*255
integer len, parent, ptr, jj, ii
jj = node(ptr).length - 1
ii = jj
do while ( ii .gt. 1 .and.
. node(ptr).spec(ii:ii) .ne. '[' .and.
. node(ptr).spec(ii:ii) .ne. '.' )
ii = ii - 1
end do
ii = ii + 1
spec = node(parent).spec(1:node(parent).length)//
. node(ptr).spec(ii:jj)//'.DIR;1'
call file_to_dir( spec,
. node(ptr).spec,
. node(ptr).length,
. node(ptr).name )
return
end
logical function check_directory_move( from_num, cur_num )
include 'swing.cmn'
integer from_num, cur_num, from_levels, ptr(0:7)
from_levels = 1
ptr(0) = from_num
ptr(1) = node(ptr(0)).child
do while( ptr(1) .ne. 0 )
if ( from_levels .lt. 2 ) from_levels = 2
ptr(2) = node(ptr(1)).child
do while( ptr(2) .ne. 0 )
if ( from_levels .lt. 3 ) from_levels = 3
ptr(3) = node(ptr(2)).child
do while( ptr(3) .ne. 0 )
if ( from_levels .lt. 4 ) from_levels = 4
ptr(4) = node(ptr(3)).child
do while( ptr(4) .ne. 0 )
if ( from_levels .lt. 5 ) from_levels = 5
ptr(5) = node(ptr(4)).child
do while( ptr(5) .ne. 0 )
if ( from_levels .lt. 6 ) from_levels = 6
ptr(6) = node(ptr(5)).child
do while( ptr(6) .ne. 0 )
if ( from_levels .lt. 7 ) from_levels = 7
ptr(7) = node(ptr(6)).child
do while( ptr(7) .ne. 0 )
if ( from_levels .lt. 8 ) from_levels = 8
ptr(7) = node(ptr(7)).sister
end do
ptr(6) = node(ptr(6)).sister
end do
ptr(5) = node(ptr(5)).sister
end do
ptr(4) = node(ptr(4)).sister
end do
ptr(3) = node(ptr(3)).sister
end do
ptr(2) = node(ptr(2)).sister
end do
ptr(1) = node(ptr(1)).sister
end do
if ( node(cur_num).level + from_levels .gt. 7 ) then
check_directory_move = .false.
else
check_directory_move = .true.
end if
return
end
subroutine create_directory( code )
include 'swing.cmn'
include '($ssdef)'
character new_dir*42, term*5, string*39, message*255
integer iterm, len_string, ii, jj
integer lib$create_dir
integer sys$getmsg, istat, len_message, code
call print_message( ' ', 0 )
call smg$set_cursor_abs( window3, 1, 1 )
call smg$read_string( keyboard, string,
. 'New subdirectory name: ',
. 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. ' ' ) 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
istat = lib$create_dir( '[.'//new_dir(1:jj)//']' )
if ( istat .eq. ss$_created ) then
do_save = .true.
call add_node( new_dir(1:jj), node_num )
call adjust_node_pointers
call load_display
call update_screen( cur_line, cur_level )
call print_message( 'Created new subdirectory', 0 )
else if ( .not. istat ) then
call sys$getmsg( %val(istat), len_message, message,
. %val(1), )
call print_message( message(1:len_message), 0 )
else
call smg$erase_display( window3 )
end if
else
call smg$erase_display( window3 )
end if
return
end
logical function crt
include 'swing.cmn'
include '($dvidef)'
include '($ttdef)'
include '($tt2def)'
integer*2 b2(14)
integer*4 b4(7), buf, len_buf, sys$trnlog, sys$getdviw, dev_type,
- len_dev_type
logical*4 for$bjtest, istat
equivalence ( b4(1), b2(1) )
b2(1) = 4
b2(2) = dvi$_devdepend2
b4(2) = %loc( buf )
b4(3) = %loc( len_buf )
b2(7) = 4
b2(8) = dvi$_devtype
b4(5) = %loc( dev_type )
b4(6) = %loc( len_dev_type )
b4(7) = 0
istat = sys$getdviw( ,, 'SYS$COMMAND', b4,,,, )
crt = ( for$bjtest( buf, tt2$v_deccrt ) .or.
. dev_type .eq. tt$_vt52 )
avo = for$bjtest( buf, tt2$v_avo )
return
end
subroutine define_paste_board
include 'swing.cmn'
include '($smgdef)'
C DEC FORGOT THIS PARAMETER IN $SMGDEF
parameter SMG$S_PASTEBOARD_INFO_BLOCK = '20'x
integer smg$create_pasteboard
integer smg$create_virtual_keyboard
integer smg$set_keypad_mode
integer smg$get_pasteboard_attributes
integer istat
record /smgdef/ table
call set_notab( 'SYS$COMMAND', set_term_buf )
istat = smg$create_pasteboard( board_id )
istat = smg$get_pasteboard_attributes(board_id, %ref(table),
. %ref(SMG$S_PASTEBOARD_INFO_BLOCK))
width = table.smg$w_width
istat = smg$create_virtual_keyboard( keyboard )
istat = smg$set_keypad_mode( keyboard, 1 )
call sm_allow_repaint
return
end
subroutine define_smg_layout
include 'swing.cmn'
include '($smgdef)'
record /pd_choice_type/ sub_choices(9)
pull_choices.number = 9
pull_choices.choice(1) = 'Create'
pull_choices.code(1) = 10
pull_choices.ptr(1) = 0
pull_choices.choice(2) = 'Rename'
pull_choices.code(2) = 20
pull_choices.ptr(2) = 0
pull_choices.choice(3) = 'Move'
pull_choices.code(3) = 30
pull_choices.ptr(3) = 0
pull_choices.choice(4) = 'Delete'
pull_choices.code(4) = 40
pull_choices.ptr(4) = 0
pull_choices.choice(5) = 'Print'
pull_choices.code(5) = 50
pull_choices.ptr(5) = 0
pull_choices.choice(6) = 'Save'
pull_choices.code(6) = 60
pull_choices.ptr(6) = 0
pull_choices.choice(7) = 'Options'
pull_choices.code(7) = 70
pull_choices.ptr(7) = %loc( sub_choices(7) )
pull_choices.choice(8) = 'Help'
pull_choices.code(8) = 80
pull_choices.ptr(8) = 0
pull_choices.choice(9) = 'Exit'
pull_choices.code(9) = 90
pull_choices.ptr(9) = %loc( sub_choices(9) )
sub_choices(1).number = 0
sub_choices(2).number = 0
sub_choices(3).number = 0
sub_choices(4).number = 0
sub_choices(5).number = 0
sub_choices(6).number = 0
sub_choices(7).number = 3
sub_choices(7).choice(1) = 'DCL Command'
sub_choices(7).code(1) = 71
sub_choices(7).choice(2) = 'Display Directory'
sub_choices(7).code(2) = 72
sub_choices(7).choice(3) = 'Filer'
sub_choices(7).code(3) = 73
sub_choices(8).number = 0
sub_choices(9).number = 2
sub_choices(9).choice(1) = 'ok exit'
sub_choices(9).code(1) = 91
sub_choices(9).choice(2) = 'cancel'
sub_choices(9).code(2) = 92
call pd_load_bar( width, pull_choices)
use_window1 = .false.
return
end
subroutine delete_directory( code )
include 'swing.cmn'
include '($ssdef)'
character spec(0:MAX_LEVELS)*255, search(0:MAX_LEVELS)*255
character term*5, string*3, message*255, name*50
integer iterm, len_string, code, jj
integer sys$getmsg, istat, len_message, len(0:MAX_LEVELS)
integer icont(0:MAX_LEVELS), lib$find_file, ii
logical found_node
call print_message( ' ', 0 )
call smg$set_cursor_abs( window3, 1, 1 )
call smg$read_string( keyboard, string,
. 'Enter YES to to delete this direc'//
. 'tory and all directories below it: ',
. 3,,,,len_string,, window3 )
call str$upcase( string, string )
if ( string .eq. 'YES' ) then
do_save = .true.
call print_message('Deleting current directory structure...',0)
delete_problem = .false.
search(0)=node(node_num).spec(1:node(node_num).length)//'*.dir'
icont(0) = 0
do while ( lib$find_file( search(0), spec(0), icont(0) ) )
call file_to_dir( spec(0), search(1), len(1), name )
search(1) = search(1)(1:len(1))//'*.dir'
icont(1) = 0
do while ( lib$find_file( search(1), spec(1), icont(1) ) )
call file_to_dir( spec(1), search(2), len(2), name )
search(2) = search(2)(1:len(2))//'*.dir'
icont(2) = 0
do while ( lib$find_file( search(2), spec(2), icont(2) ) )
call file_to_dir( spec(2), search(3), len(3), name )
search(3) = search(3)(1:len(3))//'*.dir'
icont(3) = 0
do while ( lib$find_file( search(3), spec(3), icont(3) ) )
call file_to_dir( spec(3), search(4), len(4), name )
search(4) = search(4)(1:len(4))//'*.dir'
icont(4) = 0
do while ( lib$find_file( search(4), spec(4), icont(4) ) )
call file_to_dir( spec(4), search(5), len(5), name )
search(5) = search(5)(1:len(5))//'*.dir'
icont(5) = 0
do while ( lib$find_file( search(5), spec(5), icont(5) ) )
call file_to_dir( spec(5), search(6), len(6), name )
search(6) = search(6)(1:len(6))//'*.dir'
icont(6) = 0
do while ( lib$find_file( search(6), spec(6), icont(6) ))
call file_to_dir( spec(6), search(7), len(7), name )
call delete_files( search(7)(1:len(7)) )
end do
call lib$find_file_end( icont(6) )
call delete_files( search(6)(1:len(6)) )
end do
call lib$find_file_end( icont(5) )
call delete_files( search(5)(1:len(5)) )
end do
call lib$find_file_end( icont(4) )
call delete_files( search(4)(1:len(4)) )
end do
call lib$find_file_end( icont(3) )
call delete_files( search(3)(1:len(3)) )
end do
call lib$find_file_end( icont(2) )
call delete_files( search(2)(1:len(2)) )
end do
call lib$find_file_end( icont(1) )
call delete_files( search(1)(1:len(1)) )
end do
call lib$find_file_end( icont(0) )
call delete_files( search(0)(1:node(node_num).length) )
if ( 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
node_num = node_pointer(ii,jj)
else
node_num = 1
end if
else
node_num = 1
end if
call adjust_node_pointers
call load_display
cur_level = node(node_num).level
cur_line = node(node_num).line
call update_screen( cur_line, cur_level )
if ( delete_problem ) then
call print_message( 'Attempted to delete subdirectory - '//
. 'but some files could not be deleted', 0 )
else
call print_message( 'Deleted subdirectory structure', 0 )
end if
else
call print_message( 'No directories deleted', 0 )
end if
return
end
subroutine delete_file
c Craig Young 3-AUG-87
c This subroutine deletes the current file after verification.
include 'swing.cmn'
character string*5
integer old_file, old_top, old_bottom, istat, len_string
c Check if current file is a directory. If so, abort delete.
istat = index( fnode(file_num).spec(1:), '.DIR;1' )
if ( istat .eq. 0 ) then
old_file = file_num !Save current position
old_top = top_file_line !and window range
old_bottom = bottom_file_line
call print_message( ' ', 0 )
call smg$set_cursor_abs( window3, 2, 1 )
call smg$read_string( keyboard, string,
. 'Enter YES to delete this file: ',
. ,,,,len_string,, window3 )
call str$upcase( string, string )
if ( string .eq. 'YES' ) then
call lib$delete_file( fnode(file_num).spec )
call print_message( 'File deleted', 0 )
else
call print_message( 'Delete aborted', 0 )
end if
call load_files !Reload fnode array
if ( old_file .le. num_files ) then
file_num = old_file !Reset cursor position
else
file_num = 1
end if
top_file_line = old_top !Reset window range
bottom_file_line = old_bottom
call update_file_window
else
call print_message( 'Cannot delete a directory '//
. 'with the filer.', 0 )
end if
return
end
subroutine delete_files( dir_spec )
include 'swing.cmn'
include '($smgdef)'
integer len_spec, istat, ii, ipos
integer icontext, lib$delete_file, modify_file_prot, ptr
integer lib$find_file
character dir_spec*(*), spec*255
logical find_node, found_node
ii = len( dir_spec )
do while ( dir_spec(ii:ii) .eq. ' ' .and. ii .gt. 0 )
ii = ii - 1
end do
if ( find_node( dir_spec(1:ii), ptr ) ) then
found_node = .true.
call smg$change_rendition( window2, node(ptr).line,
. node(ptr).level*17+1,
. 1, 12,
. smg$m_blink + node(ptr).rend )
else
found_node = .false.
end if
icontext = 0
do while( lib$find_file( dir_spec(:ii)//'*.*;*', 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 )
if ( .not. istat ) delete_problem = .true.
else
call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
. dir_spec(:ii)//'*.*;*', 'NL:', 'NL:' )
istat = lib$delete_file( spec )
if ( .not. istat ) delete_problem = .true.
end if
end if
end do
call lib$find_file_end( icontext )
call dir_to_file( dir_spec, ii,
. spec, ipos )
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 )
if ( .not. istat ) delete_problem = .true.
else
call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
. dir_spec(:ii)//'*.*;*', 'NL:', 'NL:' )
istat = lib$delete_file( dir_spec(1:ii) )
if ( .not. istat ) delete_problem = .true.
end if
end if
if ( .not. delete_problem ) then
if ( found_node ) call delete_node( ptr )
else
if ( found_node )
. call smg$change_rendition( window2, node(ptr).line,
. node(ptr).level*17+1,
. 1, 12,
. node(ptr).rend )
end if
return
end
$*$*EOD*$*$
$ checksum 2.FOR
$ if checksum$checksum .ne. check_sum then -
$ write sys$output "Checksum failed, file probably corrupted"
$ exit