From:	CSBVAX::MRGATE!vtcf@ncsc.ARPA@SMTP 13-APR-1988 05:04
To:	ARISIA::EVERHART
Subj:	SWING 8 OF 13


Received: from ncsc.ARPA by KL.SRI.COM with TCP; Mon 11 Apr 88 09:06:42-PDT
Received: by ncsc.ARPA id AA03128; Mon, 11 Apr 88 10:57:56 CST
Date: Mon, 11 Apr 88 10:57:56 CST
From: vtcf@ncsc.ARPA (Williams)
Message-Id: <8804111657.AA03128@ncsc.ARPA>
To: info-vax@kl.sri.com
Subject: SWING 8 OF 13

$Part08:
$ File_is="SWING_4.FOR"
$ Check_Sum_is=1398357551
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X      subroutine delete_node( ptr )
X
X      include    'swing.cmn'
X      include    '($smgdef)'
X
X      logical    found_node
X      integer    ptr, ii
X
X      found_node = .false.
X      ii = 1
X
X      do while ( .not. found_node .and. ii .le. num_nodes ) 
X         if ( node(ii).sister .eq. ptr ) then
X            found_node = .true.
X            node(ii).sister = node(ptr).sister
X
X            else if ( node(ii).child .eq. ptr ) then
X            found_node = .true.
X            node(ii).child = node(ptr).sister
X            end if
X         ii = ii + 1
X      end do
X
X      if ( found_node ) then
X         node(ptr).name = ' '
X         call smg$put_chars( window2, node(ptr).name, 
X     .                                node(ptr).line, 
X     .                                node(ptr).level * 17 + 1,,
X     .                                node(ptr).rend )
X         node(ptr).level = 0
X         node(ptr).length = 0
X         node(ptr).sister = 0
X         node(ptr).child = 0
X         end if
X
X      return
X      end
X      logical function dir_to_file( dir, len_dir, file, ipos )
X
X      implicit none
X      character dir*(*), file*(*)
X      integer   len_dir, ii, ipos, istat
X
X      ii = len_dir
X      do while ( dir(ii:ii) .ne. '.' .and. ii .gt. 0 )
X         ii = ii - 1         
X      end do
X
X      if ( ii .ne. 0 ) then
X         dir_to_file = .true.
X         file = dir
X
X         istat = index( file(1:), '<' )
X         if ( istat .ne. 0 ) then
X            file(istat:istat) = '['
X            end if
X
X         file(ii:ii) = ']'
X         file(len_dir:) = '.dir;1'
X         ipos = ii
X
X         else
X         call print_message( 'Operation not allowed on main directory',
X     .                       0 )
X         dir_to_file = .false.
X         end if
X
X      return
X      end
X      subroutine draw_screen
X
X      include    'swing.cmn'
X      include    '($smgdef)'
XC
XC`009To cope with strange terminal screen lengths
XC        19 --- > linest - 5
XC        20 --- > linest - 4 
XC        23 --- > linest - 1
XC
XC
XC       Added by EH Perkins, Aug 16, 1987
XC
X
X`009integer linest
X`009common /length/ linest
X                 
X      integer    ii, jj, kk, smg$change_pbd_characteristics
X      integer    smg$change_rendition
X
X      call smg$begin_pasteboard_update( board_id )
X
X      call smg$paste_virtual_display( window2, board_id, 3, 1 )
X      call smg$paste_virtual_display( window1, board_id, 2, 1 )
X      call smg$paste_virtual_display( window3, board_id, 
X     .                                (linest - 1), 1 )
X
X      call smg$set_display_scroll_region( window3, 1, 2 )
X
X      call pd_draw_bar( board_id )
X
X      top_line = 1
X      bottom_line = (linest - 4)
X
X      node_num = node_pointer( cur_level, cur_line )
X
X      call smg$change_rendition( window2, cur_line, cur_level*17+1,
X     .                           1, 12, 
X     .                           smg$m_bold + node(node_num).rend )
X
X      if ( cur_line .gt. bottom_line ) then
X         top_line = cur_line - (linest - 5)
X         bottom_line = cur_line
X         call smg$move_virtual_display( window2, board_id, 
X     .                                  (linest - 1) - cur_line, 1 )
X         else if ( cur_line .lt. top_line ) then
X         top_line = cur_line
X         bottom_line = cur_line + (linest - 5)
X         call smg$move_virtual_display( window2, board_id, 
X     .                                     cur_line, 1 )
X         end if
X
X      call update_window1
X
X      call smg$end_pasteboard_update( board_id )
X
X      call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )
X
X      update = .true.
X
X      return
X      end
X      subroutine edit_file
X
Xc     Craig Young               3-AUG-87
X
Xc     This subroutine spawns a process which calls the editor as specified
Xc     by Swing$Edit or defaults to TPU.  When the process is terminated,
Xc     the swing process is continued.
X
X      include    'swing.cmn'
X      include    '($ssdef)'
X
X      character  string*50, logical_name*50, command*120
X      integer*2  old_file, old_top, old_bottom, len_string
X      integer*4  translate_logical, screen_num, lib$spawn, istat
X
X      old_file = file_num                       !Save current cursor position
X      old_top = top_file_line                   !Save window range
X      old_bottom = bottom_file_line
X
Xc     Check if current file is a directory.  If so, abort edit.
X
X      istat = index( fnode(file_num).spec(1:), '.DIR;1' )
X
X      if ( istat .eq. 0 ) then
X         call smg$save_physical_screen( board_id, screen_num )
X         call print_message( ' ', 0 )
X         call smg$set_cursor_abs( window3, 2, 1 )
X
X         logical_name = 'SWING$EDIT'            !Check for user's editor
X         istat = translate_logical( logical_name, string )
X         if ( istat .eq. ss$_normal ) then
X            call str$trim( string, string, len_string )
X            command = string(1:len_string)//' '//fnode(file_num).spec
X            call str$trim( command, command, len_string )
X            istat = lib$spawn( command(1:len_string) )
X            if ( istat .ne. ss$_normal ) call exit(istat)
X         else
X            call tpu$tpu ( 'tpu '//fnode(file_num).name )
X            end if
X
X         call smg$restore_physical_screen( board_id, screen_num )
X         call load_files
X         file_num = old_file                    !Reset cursor position
X         top_file_line = old_top                !Reset window range
X         bottom_file_line = old_bottom
X         call update_file_window
X
X      else
X         call print_message( 'Cannot edit a directory.', 0 )
X         end if
X
X      return
X      end
X      subroutine execute_dcl
X
Xc     Craig Young               3-AUG-87
X
Xc     This subroutine passes DCL commands to a subprocess for execution then
Xc     reads the output from the associated mailbox.  If the subprocess is
Xc     nonexistant, it is created.
X
X      include   'swing.cmn'
X
X      character  again, string*255
X      integer*2  len_string, screen_num
X      integer    key
X
X      call smg$erase_display( DCL_window )
X      call smg$label_border( DCL_window, 'DCL Command' )
X      call smg$set_cursor_abs( DCL_window, 2, 1 )
X      call smg$paste_virtual_display( DCL_window, board_id, 5, 5 )
X
X      call smg$read_string( keyboard, string, '$ ',
X     .                      ,,,,len_string,, DCL_window )
X      call str$trim( string, string, len_string )
X
X      call process_command( string, DCL_window, 0 )
X
X      call smg$put_line( DCL_window, 'Press any key to continue' )
X      call smg$read_keystroke( keyboard, key )
X
X      call smg$unpaste_virtual_display( DCL_window, board_id )
X
X      return
X      end
X      subroutine exit_swing
X
X      include    'swing.cmn'
X
X      character  string*3
X      integer    len_string
X
X      if ( proc_created ) then
X         call process_command( 'stop/id=0', window3, 1 )
X         call sys$dassgn( %val(inbox_channel) )
X         call sys$dassgn( %val(outbox_channel) )
X      end if
X
X      if ( do_save .and. swing_file_exists ) then
X         call record_structure( .false. )
X         end if
X
X      call smg$delete_pasteboard( board_id, 1 )
X
X      call smg$change_pbd_characteristics( board_id, 80,, 24 )
X
X      call Update_stack
X
X      call reset_terminal( 'SYS$COMMAND', set_term_buf )
X
X      stop ' '
X      end
X      subroutine file_options ( code )
X
Xc     Craig Young               3-AUG-87
X
Xc     This subroutine is for calling extensions to the filer.
X
X      include    'swing.cmn'
X      include    '($smgdef)'
X
X      character  choice*(pd_max_choice_len)
X      integer    code, ii
X      logical    do_bar
X
X      if ( code .eq. 0 ) then                   !Use pulldown menu
X         ii = 4
X         call pd_list_choice( board_id, keyboard, width, ii,
X     .                        %val(pull_choices.ptr(4)),
X     .                        choice, .false., code, do_bar )
X      end if
X
X      if ( code .eq. 141 )
X     .   call execute_dcl
X
X      return
X      end
X      logical function file_to_dir( file, dir, len_dir, name )
X
X      implicit none
X      character dir*(*), file*(*), name*(*), left_bracket
X      integer   len_dir, kk, ii, len_node, jj, istat
X
X      kk = 1
X      do while ( file(kk:kk) .ne. '[' .and. file(kk:kk) .ne. '<' )
X         kk = kk + 1
X      end do
X      dir = file(kk:)
X
X      ii = 1
X      do while ( dir(ii:ii) .ne. ']' .and. dir(ii:ii) .ne. '>' )
X         ii = ii + 1
X      end do
X
X      jj = ii
X      do while ( dir(jj:jj) .ne. '.' )
X         jj = jj + 1
X      end do
X
X      dir(ii:ii) = '.'
X      istat = index( dir(1:), '<' )
X      if ( istat .ne. 0 ) then
X         dir(jj:) = '>'
X         left_bracket = '<'
X      else
X         dir(jj:) = ']'
X         left_bracket = '['
X         end if
X
X      len_dir = jj
X
X      istat = index( dir(1:), '000000.' )
X      if ( istat .ne. 0 ) then
X         dir = dir(1:istat-1)//dir(istat+7:)
X         len_dir = len_dir - 7
X         ii = ii - 7
X         if ( dir(ii:ii) .ne. '.' ) ii = ii + 1
X         end if
X      
X      len_node = len_dir - ii - 1
X      if ( len_node .le. 9 ) then
X         name = left_bracket//dir(ii:len_dir)
X         else
X         name = left_bracket//dir(ii:ii+9)//'*'
X         end if
X
X      return
X      end
X      logical function find_node( dir_spec, ptr )
X
X      include    'swing.cmn'
X
X      character  dir_spec*(*)
X      integer    ii, jj, ptr
X      logical    found_node
X
X      ii = len( dir_spec )
X      do while ( dir_spec(ii:ii) .eq. ' ' .and. ii .gt. 0 ) 
X         ii = ii - 1
X      end do
X
X      jj = 1
X      found_node = .false.
X      do while ( .not. found_node .and. jj .le. max_nodes )
X         if ( node(jj).length .ne. 0 ) then
X         if ( node(jj).spec(1:node(jj).length) .eq. dir_spec(1:ii) )then
X            found_node = .true.
X            ptr = jj
X            end if
X         end if
X         jj = jj + 1
X      end do
X
X      find_node = found_node
X
X      return
X      end
X      integer function free_node
X
X      include 'swing.cmn'
X
X      integer ii
X
X      if (num_lines .ge. MAX_LINES )
X     .   call print_message( 'Directory structure is too large', 1 )
X
X      if ( num_nodes .lt. MAX_NODES ) then
X         num_nodes = num_nodes + 1
X         node(num_nodes).length = 0
X         node(num_nodes).child = 0
X         node(num_nodes).sister = 0
X         free_node = num_nodes
X
X         else
X         ii = 1
X         do while ( ii .le. MAX_NODES ) 
X            if ( node(ii).length .eq. 0 ) then
X               node(ii).length = 0
X               node(ii).child = 0
X               node(ii).sister = 0
X               free_node = ii
X               return
X               end if
X            ii = ii + 1
X         end do
X         if ( ii .gt. MAX_NODES ) 
X     .      call print_message( 'Directory structure is too large', 1 )
X         end if
X
X      return
X      end
X      subroutine get_location( disk, len_disk, root, len_root )
X      
X      implicit none
X      integer*2  len_root
X      integer*4  sys$setddir, len_disk, istat
X      character  root*255, disk*31
X
X      call lib$sys_trnlog( 'SYS$DISK', len_disk, disk )
X      istat = sys$setddir( 0, len_root, root )
X
X      root = root(1:len_root)
X
X      return
X      end
X      subroutine hardcopy( code )
X
X      include    'swing.cmn'
X      include    '($smgdef)'
X      include    '($ssdef)'
X      include    '($clidef)'
X
X      integer    column, num, ii, jj, level, ikey, start, end, len
X      integer    code, ll, kk
X      character  hard_node*12, dashes*12, out_line(MAX_LINES)*132
X      character  one_line*200
X
X      character  logical_name*50, string*255
X      integer    istat, len_string
X      integer*4  translate_logical
X
X      data dashes / '------------' /
X
X      open( unit=1, 
X     .      name='swing.lis',
X     .      carriagecontrol='list',
X     .      status='new',
X     .      err=99 )
X
X      call print_message( 'Creating hardcopy listing in SWING.LIS', 0 )
X
X      last_level = 1
X      line = 0
X      do ii = 0, MAX_LEVELS
X         last_line(ii) = 1
X      end do         
X      do ii = 1, num_lines
X         out_line(ii) = ' '
X      end do         
X
X      do jj = 1, num_lines
X         do level = 0, MAX_LEVELS
X            if ( node_pointer(level,jj) .ne. 0 ) then
X               num = node_pointer(level,jj)
X
X               column = level * 17 + 1
X               line = node(num).line
X
X               call str$trim( hard_node, node(num).name, len )
X               if ( level .lt. 7 ) then
XC     Corrected by  Frank J. Nagy <nagy%warner.hepnet@lbl.gov> 
X                  if (( node_pointer(level+1,jj) .ne. 0 ) .and. 
X     .                (len .lt. 12))
X     .               hard_node = hard_node(1:len)//dashes(len+1:12)
X                  end if
X
X               out_line(line)(column:column+11) = hard_node
X               if ( level .gt. 0 ) then
X                  out_line(line)(column-3:column-1) = '---'
X
X                  if ( level .le. last_level ) then
X                     out_line(line)(column-3:column-3) = '+'
X                     if ( out_line(line-1)(column-3:column-3) .eq. '+' )
X     .                  out_line(line-1)(column-3:column-3) = '|'
X                        
X                     else if ( level .eq. last_level + 1 ) then
X                     out_line(line)(column-5:column-2) = '----'
X                     end if
X
X                  if ( level .lt. last_level ) then
X                     if ( out_line(last_line(level))(column-3:column-3) 
X     .                    .eq. '+' ) then
X                        ll = last_line(level)
X                        else
X                        ll = last_line(level) + 1
X                        end if
X                     do kk = ll, line-1
X                        out_line(kk)(column-3:column-3) = '|'
X                     end do
X                     end if
X                  end if
X
X               last_level = level
X               last_line(level) = line
X               end if
X         end do
X      end do
X
X      do ii = 1, num_lines
X         call str$trim( out_line(ii), out_line(ii), len )
X         write( 1, 100 ) out_line(ii)(1:len)
X100      format( a )
X      end do
X
X      call print_message( 'Finished creating SWING.LIS', 
X     .                    0 )
X
X      close( unit=1 )
X
X      logical_name = 'SWING$PRINT'           !Check for user's printer
X      istat = translate_logical( logical_name, string )
X      if ( istat .eq. ss$_normal ) then
X         call str$trim( string, string, len_string )
X         call lib$spawn( string(1:len_string)
X     .                   //'/noidentify/nonotify/delete '
X     .                   //'swing.lis',,,cli$m_nowait)
X      else
X         call lib$spawn( '$print/noidentify/nonotify/delete '
X     .                   //'swing.lis',,,cli$m_nowait)
X         end if
X
X      call print_message( 'Sent file to printer.', 0 )
X      return
X
X99    call print_message( 'Unable to open file for hardcopy', 0 )
X      return
X      end
$ GoSub Convert_File
$ Goto Part09

