From:	CSBVAX::MRGATE!vtcf@ncsc.ARPA@SMTP 13-APR-1988 06:00
To:	ARISIA::EVERHART
Subj:	SWING 12 OF 13


Received: from ncsc.ARPA by KL.SRI.COM with TCP; Mon 11 Apr 88 09:51:18-PDT
Received: by ncsc.ARPA id AA03429; Mon, 11 Apr 88 11:47:49 CST
Date: Mon, 11 Apr 88 11:47:49 CST
From: vtcf@ncsc.ARPA (Williams)
Message-Id: <8804111747.AA03429@ncsc.ARPA>
To: info-vax@kl.sri.com
Subject: SWING 12 OF 13

$Part12:
$ File_is="SWING_8.FOR"
$ Check_Sum_is=1378287651
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X      subroutine print_message( message, abort )
X
X      include    'swing.cmn'
X
X      logical    abort, erased
X      character  message*(*)
X
X      if ( using_screen ) then
X
X         if ( message .eq. ' ' ) then
X            if ( .not. erased ) then
X               erased = .true.
X               call smg$erase_display( window3 )
X               call smg$erase_line( window3, 2, 1 )
X               end if
X
X            else
X            erased = .false.
X            call smg$erase_display( window3 )
X            call smg$put_chars( window3, message, 2, 1, 1 )
X            end if
X
X         if ( abort ) call exit_swing
X                  
X         else
X         print *, 'SWING: ', message
X         if ( abort ) stop ' '
X         end if
X
X      return
X      end
X        subroutine process_command ( out_message, window, stop )
X
Xc       Craig Young             3-AUG-87
X
X        include   'swing.cmn'
X        include   '($syssrvnam)'
X        include   '($ssdef)'
X        include   '($iodef)'
X        include   '($clidef)'
X
X        integer     window, stop
X        integer*4   status, done, proc_id, message_len, lib$spawn
X        integer*4   str$position
X        character   in_message*100, out_message*100, terminator*50
X        character   set_noon*8/'set noon'/
X        parameter 
X     -  (terminator = 'swing dcl subprocess command output terminator')
X
X        message_len = 100
X
X        if ( proc_created .eq. 0 ) then
X           status = sys$crembx ( ,outbox_channel ,,,,,'swing_dcl_inbox')
X           if ( status .ne. ss$_normal ) call exit(status)
X           status = sys$crembx ( ,inbox_channel ,,,,,'swing_dcl_outbox')
X           if ( status .ne. ss$_normal ) call exit(status)
X
X           status = lib$spawn ( ,'swing_dcl_inbox' ,'swing_dcl_outbox'
X     -                          ,cli$m_nowait ,,proc_id 
X     -                          ,,done )
X           if (status .ne. ss$_normal) call exit(status)
X           status = sys$qiow( ,%val(outbox_channel)
X     -                     ,%val(io$_writevblk) ,
X     -                     ,,,%ref(set_noon)
X     -                     ,%val(len(set_noon)) ,,,, )
X           if ( status .ne. ss$_normal ) call exit(status)
X           proc_created = 1
X           end if
X
X        status = sys$qiow( ,%val(outbox_channel)
X     -                     ,%val(io$_writevblk) ,
X     -                     ,,,%ref(out_message)
X     -                     ,%val(message_len) ,,,, )
X        if ( status .ne. ss$_normal ) call exit(status)
X
X        if ( stop .eq. 0 ) then
X           out_message = 'write sys$output "'//terminator//'"'
X
X           status = sys$qio ( ,%val(outbox_channel)
X     -                        ,%val(io$_writevblk) ,
X     -                        ,,,%ref(out_message)
X     -                        ,%val(message_len) ,,,, )
X           if ( status .ne. ss$_normal ) call exit(status)
X
X           in_message = '      '
X           status = 0
X           do while ( in_message .ne. terminator )
X              if ( window .eq. DCL_window ) then
X                 call smg$put_line( window, in_message )
X              else
X                 if ( in_message .ne. '     ' ) then
X                    call print_message( in_message, 0 )
X                    end if
X                 end if
X
X              in_message = '      '
X              status = sys$qiow( ,%val(inbox_channel) 
X     -                           ,%val(io$_readvblk) ,
X     -                           ,,,%ref(in_message)
X     -                           ,%val(message_len) ,,,, )
X              if ( status .ne. ss$_normal ) call exit(status)
X
X              end do
X           end if
X
X        return
X        end
X      subroutine record_structure( search )
X
X      include    'swing.cmn'
X     
X      character  spec*255
X      logical    search, modify_file_prot
X      integer    icontext, ii, jj, istat, len_spec
X      integer    lib$find_file, lib$delete_file
X                 
X      if ( search .and. swing_file_exists ) then
X         do ii = 1, num_nodes
X            node(ii).length = 0
X            node(ii).child = 0
X            node(ii).sister = 0
X         end do
X
X         call load_nodes
X   
X         call load_display
X   
X         call update_screen( cur_line, cur_level )
X         end if
X 
X      do_save = .false.
X
X      call print_message( 'Saving directory structure', 0 )
X
X      icontext = 0
X      do while( lib$find_file( main(1:len_main)//'swing.sav;*',
X     .                         spec, icontext ))
X         if ( .not. lib$delete_file( spec ) ) then
X            call str$trim( spec, spec, len_spec )
X            if ( modify_file_prot( spec(1:len_spec), 0, 0 ) ) then
X               istat = lib$delete_file( spec )
X               else 
X               call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
X     .                         main(1:len_main)//'swing.sav', 
X     .                         'NL:', 'NL:' )
X               istat = lib$delete_file( spec )
X               end if
X            end if
X      end do
X      call lib$find_file_end( icontext )
X
X      open( unit=2, 
X     .      name=main(1:len_main)//'swing.sav', 
X     .      status='new',
X     .      carriagecontrol='list',
X     .      access='sequential',
X     .      form='unformatted',
X     .      recl=73,
X     .      organization='sequential',
X     .      recordtype='variable',
X     .      iostat=istat,
X     .      err=99 )
X
X      write( 2 ) num_lines, num_nodes, lowest_level
X
X      do ii = 1, num_lines
X         write( 2 ) (node_pointer(jj,ii), jj=0, MAX_LEVELS)
X      end do
X
X      do ii = 1, num_nodes
X         write( 2 ) node(ii)
X      end do
X
X      close( unit=2 )
X
X      swing_file_exists = .true.
X
X      call print_message( 'Finished saving directory structure', 0 )
X
X      return
X
X99    call print_message( 'Unable to record directory structure', 0 )
X      return
X      end
X      subroutine redefine_smg_layout
X
Xc     Craig Young               3-AUG-87
X
Xc     This subroutine redefines the options for the command bar.
X
X      include    'swing.cmn'
X      include    '($smgdef)'
X
X      record /pd_choice_type/ sub_choices(8)
X
X      pull_choices.number = 8
X      pull_choices.choice(1) = 'Delete'
X      pull_choices.code(1) = 110
X      pull_choices.ptr(1) = 0
X      pull_choices.choice(2) = 'Edit'
X      pull_choices.code(2) = 120
X      pull_choices.ptr(2) = 0
X      pull_choices.choice(3) = 'Move'
X      pull_choices.code(3) = 130
X      pull_choices.ptr(3) = 0
X      pull_choices.choice(4) = 'Options'
X      pull_choices.code(4) = 140
X      pull_choices.ptr(4) = %loc( sub_choices(4) )
X      pull_choices.choice(5) = 'Print'
X      pull_choices.code(5) = 150
X      pull_choices.ptr(5) = 0
X      pull_choices.choice(6) = 'Rename'
X      pull_choices.code(6) = 160
X      pull_choices.ptr(6) = 0
X      pull_choices.choice(7) = 'Help'
X      pull_choices.code(7) = 170
X      pull_choices.ptr(7) = 0
X      pull_choices.choice(8) = 'Quit'
X      pull_choices.code(8) = 180
X      pull_choices.ptr(8) = %loc( sub_choices(8) )
X
X      sub_choices(4).number = 1
X      sub_choices(4).choice(1) = 'DCL Command'
X      sub_choices(4).code(1) = 141
X      sub_choices(4).ptr(1) = 68
X      sub_choices(8).number = 2
X      sub_choices(8).choice(1) = 'Okay, quit filer'
X      sub_choices(8).code(1) = 181
X      sub_choices(8).ptr(1) = 79
X      sub_choices(8).choice(2) = 'Cancel'
X      sub_choices(8).code(2) = 182
X      sub_choices(8).ptr(2) = 67
X
X      call pd_load_bar( width, pull_choices )
X
X      return
X      end                     
X      subroutine rename_directory( code ) 
X
X      include    'swing.cmn'
X      include    '($ssdef)'
X      include    '($smgdef)'
X
X      character  new_dir*42, key, string*39, message*255, file*255
X      integer    ikey, len_string, lib$rename_file, code, parent
X      integer    sys$getmsg, istat, len_message, ipos, from_level
X      integer    old_line, old_level, from_num, from_line, ii, jj
X      logical    dir_to_file, finished, check_directory_move
X
X      if ( code .eq. 20 ) then
X
X         call print_message( ' ', 0 )
X         call smg$set_cursor_abs( window3, 1, 1 )
X         call smg$read_string( keyboard, string, 
X     .                         'Enter new name to give directory: ',
X     .                         39,,,,len_string,, window3 )
X
X         new_dir = ' '
X         jj = 0
X
X         do ii = 1, len_string
X            if (string(ii:ii) .ne. '[' .and. string(ii:ii) .ne. ']'.and.
X     .         string(ii:ii) .ne. '.' .and. string(ii:ii) .gt. ' ' .and.
X     .         string(ii:ii) .ne. ';' ) then
X               jj = jj + 1
X               new_dir(jj:jj) = string(ii:ii)
X               end if
X         end do
X
X         call str$upcase( new_dir, new_dir )
X
X         if ( jj .ne. 0 ) then
X            if ( dir_to_file( node(node_num).spec,
X     .                        node(node_num).length, 
X     .                        file, ipos ) ) then
X               istat = lib$rename_file( file, 
X     .                                  new_dir(1:jj)//'.DIR;1',,,
X     .                                  1 )
X
X               if ( istat .eq. ss$_normal ) then
X                  call file_to_dir( file(1:ipos)//new_dir(1:jj)//'.DIR', 
X     .                              node(node_num).spec,
X     .                              node(node_num).length,
X     .                              node(node_num).name )
X 
X                  parent = 0
X                  call move_node( node_num, parent )
X   
X                  call adjust_node_pointers
X        
X                  call load_display
X
X                  cur_line = node(node_num).line
X                  cur_level = node(node_num).level
X
X                  call update_screen( cur_line, cur_level )
X
X                  call print_message( 'Subdirectory renamed', 0 )
X
X                  do_save = .true.
X
X                  else
X                  call sys$getmsg( %val(istat), len_message, message, 
X     .                             %val(1), )
X                  call print_message( message(1:len_message), 0 )
X                  end if
X               end if
X            else
X            call smg$erase_display( window3 )
X            end if
X
X         else if ( code .eq. 30 ) then
X
X         from_num = node_num
X         from_line = cur_line
X         from_level = cur_level         
X         node(from_num).rend = smg$m_reverse + smg$m_blink
X
X         call smg$change_rendition( window2, from_line, from_level*17+1,
X     .                              1, 12, node(from_num).rend )
X
X         call print_message( 'Travel to new parent directory and hit '// 
X     .                       'RETURN - Hit any other key to abort', 0 )
X         call smg$set_cursor_abs( window2, from_line, from_level*17+1 )
X
X         finished = .false.
X
X         do while ( .not. finished ) 
X
X            call smg$read_keystroke( keyboard, ikey )
X
X            old_line = cur_line
X            old_level = cur_level
X            old_rend = node(node_num).rend 
X
X            if ( ikey .eq. smg$k_trm_cr .or. 
X     .           ikey .eq. smg$k_trm_enter ) then
X               finished = .true.
X
X               else if ( ikey .eq. smg$k_trm_up ) then
X               ii = cur_level
X               jj = cur_line - 1
XC     Corrected by  Frank J. Nagy <nagy%warner.hepnet@lbl.gov> 
X               do while( jj .ge. 1 .and. node_pointer(ii,jj) .eq. 0 )`009!LAW
X                  jj = jj - 1
X               end do
X               if ( jj .ge. 1 ) cur_line = jj
X               call update_screen( old_line, old_level )
X 
X               else if ( ikey .eq. smg$k_trm_down ) then
X               ii = cur_level
X               jj = cur_line + 1
X               do while( node_pointer(ii,jj) .eq. 0 .and.
X     .                   jj .le. num_lines ) 
X                  jj = jj + 1
X               end do
X               if ( jj .le. num_lines ) cur_line = jj
X               call update_screen( old_line, old_level )
X
X               else if ( ikey .eq. smg$k_trm_right ) then
X               ii = cur_level + 1
X               jj = cur_line 
X               do while( node_pointer(ii,jj) .eq. 0 .and.
X     .                   ii .le. MAX_LEVELS ) 
X                  ii = ii + 1
X               end do
X               if ( ii .le. MAX_LEVELS ) cur_level = ii
X               call update_screen( old_line, old_level )
X
X               else if ( ikey .eq. smg$k_trm_left .and. 
X     .                   cur_level .ge. 1 ) then
X               ii = cur_level - 1
X               jj = cur_line
X               do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 ) 
X                  jj = jj - 1
X               end do
X               if ( jj .ge. 1 ) then
X                  cur_level = ii
X                  cur_line = jj
X                  end if
X               call update_screen( old_line, old_level )
X  
X               else
X               finished = .true.
X               end if
X
X            call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )
X
X         end do
X
X         node(from_num).rend = smg$m_reverse
X
X         call smg$change_rendition( window2, from_line, from_level*17+1,
X     .                              1, 12, node(from_num).rend )
X
X         if ( ikey .eq. smg$k_trm_cr .or. 
X     .        ikey .eq. smg$k_trm_enter ) then
X
X            if ( .not. check_directory_move( from_num, node_num ) ) then
X               call update_screen( cur_line, cur_level )
X               call print_message( 'Rename would cause too great a '//
X     .            'directory depth', 0 )
X               return
X               end if               
X
X            if ( dir_to_file( node(from_num).spec,
X     .                        node(from_num).length, 
X     .                        file, ipos ) ) then
X
X               istat = lib$rename_file( file, 
X     .                 node(node_num).spec(1:node(node_num).length)//
X     .                 '*.dir;1',,, 1 )
X
X               if ( istat ) then
X                  call move_node( from_num, node_num )
X   
X                  call adjust_node_pointers
X        
X                  call load_display
X
X                  cur_line = node(from_num).line
X                  cur_level = node(from_num).level
X
X                  call update_screen( cur_line, cur_level )
X
X                  call print_message( 'Subdirectory has been moved', 0 )
X
X                  do_save = .true.
X
X                  else
X                  call sys$getmsg( %val(istat), len_message, message, 
X     .                             %val(1), )
X                  call print_message( message(1:len_message), 0 )
X                  end if
X               end if
X            else
X            call smg$erase_display( window3 )
X            end if
X         else
X         call smg$erase_display( window3 )
X         end if
X
X      return
X      end
X
$ GoSub Convert_File
$ Goto Part13
