Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!utgpu!water!watnot!watmath!clyde!cbatt!ucbvax!u3369429@seismo.CSS.GOV@murdu.OZ.AU
From: u3369429@seismo.CSS.GOV@murdu.OZ.AU
Newsgroups: mod.computers.vax
Subject: SWING (modified) part 3 of 6
Message-ID: <8703030251.10242@murdu.OZ>
Date: Tue, 3-Mar-87 13:51:42 EST
Article-I.D.: murdu.8703030251.10242
Posted: Tue Mar  3 13:51:42 1987
Date-Received: Thu, 5-Mar-87 18:47:31 EST
Sender: daemon@ucbvax.BERKELEY.EDU
Reply-To: munnari!u3369429@seismo.CSS.GOV (Michael Bednarek)
Distribution: world
Organization: I.A.E.S.R., Melbourne University
Lines: 680
Approved: info-vax@sri-kl.arpa

$write sys$error "extract HELP.FOR"
$copy sys$input HELP.FOR
$deck/dollars="870303:12:53:38"
      subroutine help

      include    'swing.cmn/List'
      include    '($hlpdef)/List'

      external   LIB$PUT_OUTPUT, LIB$GET_INPUT

      integer    isave, flags, input, output, stat
      integer    lbr$output_help

      call smg$save_physical_screen( board_id, isave )

!!! The changes in this section allow for private help libraries.
!!!   flags = hlp$m_prompt			! Michael Bednarek changed to:
      flags = hlp$m_prompt.or.HLP$M_PROCESS

      output = %loc( lib$put_output )
      input =  %loc( lib$get_input )

      stat = lbr$output_help( %val(output),
     .                        width,
     .                        'swing',
     .                        ,		!!! was 'swing',
     .                        flags,
     .                        %val(input) )

      call smg$restore_physical_screen( board_id, isave )

      if ( .not. stat ) call print_message('Can''t find help entry for SWING. Sorry.', 0 )

      return
      end
870303:12:53:38
$write sys$error "extract LOAD_DISPLAY.FOR"
$copy sys$input LOAD_DISPLAY.FOR
$deck/dollars="870303:12:53:38"
      subroutine load_display

      include    '($smgdef)/List'
      include    'swing.cmn/List'

      integer    jj, level

      using_screen = .true.

      if ( .not. found ) then
         cur_level = 0
         cur_line = 1
         end if

      last_level = 0
      line = 0
      do ii = 0, MAX_LEVELS
         last_line(ii) = 1
      end do

      if ( lowest_level .gt. 4 .and. width .ne. 132 ) then
         width = 132
         call pd_undraw_bar( board_id )
         call smg$erase_display( window1 )
         call smg$erase_display( window2 )
         call smg$erase_display( window3 )
         istat = smg$change_pbd_characteristics( board_id,132,,24 )
         call smg$set_display_scroll_region( window3, 1, 2 )
         call pd_load_bar( width, pull_choices)
         call pd_draw_bar( board_id )

         else if ( lowest_level .le. 4 .and. width .ne. 80 ) then
         width = 80
         call pd_undraw_bar( board_id )
         call smg$erase_display( window1 )
         call smg$erase_display( window2 )
         call smg$erase_display( window3 )
         istat = smg$change_pbd_characteristics( board_id,80,,24 )
         call smg$set_display_scroll_region( window3, 1, 2 )
         call pd_load_bar( width, pull_choices)
         call pd_draw_bar( board_id )
         end if

      call smg$begin_pasteboard_update( board_id )

      call smg$erase_display( window2 )

      do jj = 1, num_lines
         do level = 0, MAX_LEVELS
            if ( node_pointer(level,jj) .ne. 0 )
     .         call add_node_to_display( node_pointer(level,jj) )
         end do
      end do

c     PUT UNDERLINES ON THE LEAF NODES

      do jj = 2, num_nodes
         do ii = 2, MAX_LEVELS
            if ( node_pointer(ii,jj) .ne. 0 .and.
     .           node_pointer(ii-1,jj) .ne. 0 .and.
     .           node_pointer(ii,jj-1) .ne. 0 ) then
               kk = node_pointer( ii, jj-1 )
               node(kk).rend = smg$m_underline + smg$m_reverse
               istat = smg$change_rendition( window2, node(kk).line,
     .                                       node(kk).level*17+1,
     .                                       1, 12, node(kk).rend )
               end if
         end do
      end do

      call smg$end_pasteboard_update( board_id )

      if ( .not. found )
     .   call print_message( 'The current directory was not found in'//
     .                       ' your save file', 0 )

      return
      end
870303:12:53:38
$write sys$error "extract LOAD_NODES.FOR"
$copy sys$input LOAD_NODES.FOR
$deck/dollars="870303:12:53:38"
      subroutine load_nodes

      include    'swing.cmn/List'

      integer*2  len_root
      integer*4  icontext(MAX_LEVELS), lib$find_file,
	1	LIB$SYS_TRNLOG,lTR
      character  input*255, spec*255, search(0:MAX_LEVELS)*255,
	1	 TR*255

      do ii = 1, MAX_LINES
         do jj = 0, MAX_LEVELS
            node_pointer(jj,ii) = 0
         end do
      end do

      call get_location( disk, len_disk, root, len_root )

      found = .false.
      lowest_level = 0
      last_level = 1
      line = 0
      num_nodes = 0
      node_num = 0

! Added by Michael Bednarek:
! A directory name may be surrounded either by "[]" or "<>".

	ii=INDEX(root,'<')
	If (ii.ne.0) then
	  root(ii:ii)='['
	  ii=INDEX(root,'>')
	  root(ii:ii)=']'
	End If

! Find top-level
      ii = 1
      do while ( root(ii:ii) .ne. '.' .and. root(ii:ii) .ne. ']')
         ii = ii + 1
      end do

      main = root(:ii-1)//']'
      len_main = ii
      spec = main

! Michael Bednarek disabled the next statement:
!!!	if (main .eq. '[000000]') call print_message('Master file directory not allowed',1)

! Create a file name for the save file (Michael Bednarek)
! The rationale behind this is that I don't want to write the SWING.SAV file
! into other users' directories.
! If the logical name SWING_SAVE exists,
	If (LIB$SYS_TRNLOG('SWING_SAVE',lTR,TR,,,%VAL(0)).eq.1) then
! construct a file name like: SWING_SAVE:USERNAME_SWING.SAV
	  main(1:len_main+10)='SWING_SAVE:'//main(2:len_main-1)//'_'
	  len_main=len_main+10
	End If
	
      ii = 0
      if ( .not. update .and. lib$find_file( main(1:len_main)//
     .     'swing.sav', input, ii ) ) then

         open( unit=1,
     .         readonly,
     .         name=main(1:len_main)//'swing.sav',
     .         status='old',
     .         carriagecontrol='list',
     .         access='sequential',
     .         form='unformatted',
     .         recl=73,
     .         organization='sequential',
     .         recordtype='variable',
     .         err=99 )

         read( 1, err=99 ) num_lines, num_nodes, lowest_level

         do ii = 1, num_lines
            read( 1, err=99 ) (node_pointer(jj,ii), jj=0,MAX_LEVELS)
         end do

         do ii = 1, num_nodes
            read( 1, err=99 ) node(ii)
         end do

         close( unit=1 )

         swing_file_exists = .true.

         else
99       call print_message( 'Searching directory structure...', 0 )

         call append_node( 0, spec, search(1) )

         icontext(1) = 0
         do while ( lib$find_file( search(1), spec, icontext(1) ) )
          call append_node( 1, spec, search(2) )
          icontext(2) = 0
          do while ( lib$find_file( search(2), spec, icontext(2) ) )
           call append_node( 2, spec, search(3) )
           icontext(3) = 0
           do while ( lib$find_file( search(3), spec, icontext(3) ) )
            call append_node( 3, spec, search(4) )
            icontext(4) = 0
            do while ( lib$find_file( search(4), spec, icontext(4) ) )
             call append_node( 4, spec, search(5) )
             icontext(5) = 0
             do while ( lib$find_file( search(5), spec, icontext(5) ) )
              call append_node( 5, spec, search(6) )
              icontext(6) = 0
              do while ( lib$find_file( search(6), spec, icontext(6) ) )
               call append_node( 6, spec, search(7) )
               icontext(7) = 0
               do while ( lib$find_file( search(7), spec, icontext(7) ))
                call append_node( 7, spec, search(0) )
               end do
               call lib$find_file_end( icontext(7) )
              end do
              call lib$find_file_end( icontext(6) )
             end do
             call lib$find_file_end( icontext(5) )
            end do
            call lib$find_file_end( icontext(4) )
           end do
           call lib$find_file_end( icontext(3) )
          end do
          call lib$find_file_end( icontext(2) )
         end do
         call lib$find_file_end( icontext(1) )
         end if

      return
      end
870303:12:53:38
$write sys$error "extract MODIFY_FILE_PROT.FOR"
$copy sys$input MODIFY_FILE_PROT.FOR
$deck/dollars="870303:12:53:38"
      INTEGER*4 FUNCTION MODIFY_FILE_PROT ( FILE, PROT, CODE )

C     Modifies  the protection  on a specified  file.  The file's access
C     control list, if it  has one, is not modified.  The status of  the
C     operation is returned as a function value.

C     This routine will fail if the protection on the file (prior to the
C     modification) is such that we do not have read and write access to
C     it.  It will also fail if the file has already been opened without
C     write-shareability.

C     Greg Janee, 19-MAR-1986

C-----------------------------------------------------------------------

C     Arguments:
C
C     FILE      type:      character string
C               access:    read only
C               mechanism: by descriptor, fixed-length descriptor
C
C     The filename of  the file whose  protection is to be modified.  If
C     the string is larger than 255 bytes, only the first 255  bytes are
C     used.
C
C     PROT      type:      unsigned word
C               access:    read only
C               mechanism: by reference
C
C     The bit mask  that is to replace  or modify the  file's protection
C     bits.  The mask  should be  specified in  the format  described by
C     section 12.13 of the VAX Record Management Services Reference Man-
C     ual.
C
C     CODE      type:      signed longword integer
C               access:    read only
C               mechanism: by reference
C
C     The type of modification to be performed on  the file's protection
C     bits.  A  value of 0 indicates the  bits are to be replaced by the
C     PROT argument;  values  1, 2, and 3 indicate  the bits  are  to be
C     ANDed, inclusive-ORed, or  exclusive-ORed with the  PROT argument,
C     respectively.  The  protection  bits  are left  unchanged  for all
C     other values of this argument.

C=======================================================================

      IMPLICIT  NONE

      INCLUDE   '($FABDEF)/List'
      INCLUDE   '($XABDEF)/List'
      INCLUDE   '($XABPRODEF)/List'

C     We have to define our own structure to access a XABPRO because DEC
C     is too stupid to define theirs correctly.

      STRUCTURE /XABPRO/
         UNION
            MAP
               RECORD /XABDEF/     A
            END MAP
            MAP
               RECORD /XABPRODEF1/ B
            END MAP
         END UNION
      END STRUCTURE

      CHARACTER FILE*(*)
      INTEGER*2 PROT
      INTEGER*4 CODE

      RECORD    /FABDEF/ FAB
      RECORD    /XABPRO/ XAB

      INTRINSIC JMIN0
      INTRINSIC LEN
      EXTERNAL  LIB$INSV
      EXTERNAL  LIB$MOVC5
      EXTERNAL  SYS$CLOSE
      INTEGER*4 SYS$CLOSE
      EXTERNAL  SYS$OPEN
      INTEGER*4 SYS$OPEN

C-----------------------------------------------------------------------

C     First initialize and  link a FAB and XAB.  Note that  if we do not
C     open the  file with some sort  of write access the protection will
C     not be changed.

      CALL LIB$MOVC5 ( 0, 0, 0, FAB$C_BLN, FAB )

      FAB.FAB$B_BID = FAB$C_BID
      FAB.FAB$B_BLN = FAB$C_BLN
      FAB.FAB$B_FAC = FAB$M_PUT
      FAB.FAB$L_FNA = %LOC( FILE )
      CALL LIB$INSV ( JMIN0( LEN(FILE), 255 ), 0, 8, FAB.FAB$B_FNS )

C     RMS will balk if the  file has been opened by  someone else.  With
C     the following SHR options we'll at least get through the case when
C     the file has been opened write-shared.

      FAB.FAB$B_SHR = FAB$M_SHRPUT .OR. FAB$M_SHRGET .OR.
     .                FAB$M_SHRDEL .OR. FAB$M_SHRUPD .OR. FAB$M_UPI

      FAB.FAB$L_XAB = %LOC( XAB )

      CALL LIB$MOVC5 ( 0, 0, 0, XAB$C_PROLEN, XAB )

      XAB.A.XAB$B_BLN = XAB$C_PROLEN
      XAB.A.XAB$B_COD = XAB$C_PRO

C-----------------------------------------------------------------------

C     There is  no RMS service to  change file protections.  To do so we
C     open the file with write access and then close  it with a new pro-
C     tection mask.

      MODIFY_FILE_PROT = SYS$OPEN( FAB )
      IF ( .NOT.MODIFY_FILE_PROT ) RETURN

      IF     ( CODE .EQ. 0 ) THEN
         XAB.B.XAB$W_PRO =                       PROT
      ELSEIF ( CODE .EQ. 1 ) THEN
         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .AND. PROT
      ELSEIF ( CODE .EQ. 2 ) THEN
         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .OR.  PROT
      ELSEIF ( CODE .EQ. 3 ) THEN
         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .XOR. PROT
      END IF

      MODIFY_FILE_PROT = SYS$CLOSE( FAB )
      RETURN

C=======================================================================

      END
870303:12:53:38
$write sys$error "extract MOVE_NODE.FOR"
$copy sys$input MOVE_NODE.FOR
$deck/dollars="870303:12:53:38"
      subroutine move_node( num, parent )

      include    'swing.cmn/List'

      logical    found_node, greater
      integer    num, ii, jj, parent, ptr(0:7)

      found_node = .false.
      ii = 1

      do while ( .not. found_node .and. ii .le. num_nodes )
         if ( node(ii).sister .eq. num ) then
            found_node = .true.
            node(ii).sister = node(num).sister

            else if ( node(ii).child .eq. num ) then
            found_node = .true.
            node(ii).child = node(num).sister
            end if
         ii = ii + 1
      end do

      if ( .not. found_node ) return

      node(num).sister = 0

      if ( parent .eq. 0 ) 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
            parent = node_pointer(ii,jj)
            else
            parent = 1
            end if
         end if

      if ( node(parent).child .eq. 0 ) then
         node(parent).child = num

         else
         ii = node(parent).child
         if ( node(num).name .lt. node(ii).name ) then
            node(num).sister = node(parent).child
            node(parent).child = num

            else
            greater = .true.
            do while ( greater )
               if ( node(ii).sister .eq. 0 ) then
                  node(ii).sister = num
                  greater = .false.

                  else
                  jj = ii
                  ii = node(ii).sister
                  if ( node(num).name .lt. node(ii).name ) then
                     node(jj).sister = num
                     node(num).sister = ii
                     greater = .false.
                     end if
                  end if
            end do
            end if
         end if

      ptr(0) = num

      call change_spec( parent, ptr(0) )
      ptr(1) = node(ptr(0)).child
      do while( ptr(1) .ne. 0 )
        call change_spec( ptr(0), ptr(1) )
        ptr(2) = node(ptr(1)).child
        do while( ptr(2) .ne. 0 )
          call change_spec( ptr(1), ptr(2) )
          ptr(3) = node(ptr(2)).child
          do while( ptr(3) .ne. 0 )
            call change_spec( ptr(2), ptr(3) )
            ptr(4) = node(ptr(3)).child
            do while( ptr(4) .ne. 0 )
              call change_spec( ptr(3), ptr(4) )
              ptr(5) = node(ptr(4)).child
              do while( ptr(5) .ne. 0 )
                call change_spec( ptr(4), ptr(5) )
                ptr(6) = node(ptr(5)).child
                do while( ptr(6) .ne. 0 )
                  call change_spec( ptr(5), ptr(6) )
                  ptr(7) = node(ptr(6)).child
                  do while( ptr(7) .ne. 0 )
                    call change_spec( ptr(6), ptr(7) )
                    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

      return
      end
870303:12:53:38
$write sys$error "extract PD_BAR_CHOICE.FOR"
$copy sys$input PD_BAR_CHOICE.FOR
$deck/dollars="870303:12:53:38"
      subroutine pd_bar_choice( keyboard, num_choice, pd_choices )

      include '($smgdef)/List'
      include 'pulldown.cmn/List'

      integer pos, new_pos, key, num_choice, keyboard
      logical exit, down
      record /pd_choice_type/ pd_choices

      exit = .false.
      down = .false.
      key = 0
      new_pos = num_choice
      pos = num_choice

C     SET THE RENDITION OF THE FIRST CHOICE
      ii = 1 + (pd_cell_size*(new_pos-1))
      call smg$change_rendition( pd_bar_id, 1, ii, 1,
     .                           pd_cell_size, smg$m_bold )

      do while ( key .ne. smg$k_trm_enter .and.
     .           key .ne. smg$k_trm_cr .and.
     .           .not. down .and. .not. exit )

         call smg$set_cursor_abs( pd_bar_id, 1, 1 )

         call smg$read_keystroke( keyboard, key )

         if ( key .eq. smg$k_trm_left ) then
            if ( pos .gt. 1 ) new_pos = pos - 1
            else if ( key .eq. smg$k_trm_right ) then
            if ( pos .lt. pd_num_choices ) new_pos = pos + 1
            else if ( key .eq. smg$k_trm_down ) then
            if ( pd_choices.ptr(pos) .ne. 0 ) down = .true.
            else if ( key .eq. smg$k_trm_ctrlz ) then
            exit = .true.
            end if

         if ( new_pos .ne. pos ) then
            ii = 1 + (pd_cell_size*(pos-1))
            call smg$change_rendition( pd_bar_id, 1, ii, 1,
     .                                 pd_cell_size, 0, 0 )
            ii = 1 + (pd_cell_size*(new_pos-1))
            call smg$change_rendition( pd_bar_id, 1, ii, 1,
     .                                 pd_cell_size, smg$m_bold )
            end if

         pos = new_pos

      end do

      ii = 1 + (pd_cell_size*(pos-1))
      call smg$change_rendition( pd_bar_id, 1, ii, 1,
     .                           pd_cell_size, 0, 0 )

      if ( exit ) then
         num_choice = 0
         else
         num_choice = pos
         end if

      return
      end
870303:12:53:38
$write sys$error "extract PD_DRAW_BAR.FOR"
$copy sys$input PD_DRAW_BAR.FOR
$deck/dollars="870303:12:53:38"
      subroutine pd_draw_bar( board_id )

*     PD_DRAW_BAR( BOARD_ID )
*
*     BOARD_ID          INTEGER*4
*
      include 'pulldown.cmn/List'

      integer board_id

      call smg$unpaste_virtual_display( pd_bar_id, board_id )
      call smg$paste_virtual_display( pd_bar_id, board_id, 1, 1 )

      return
      end
870303:12:53:38
$write sys$error "extract PD_GET_CHOICE.FOR"
$copy sys$input PD_GET_CHOICE.FOR
$deck/dollars="870303:12:53:38"
*=======================================================================
*
*  Title:        PULLDOWN PACKAGE
*
*  Version:      1-001
*
*  Abstract:     This is a package of routines to implement a pulldown
*                menu system on a VT100 type terminal with SMG routines.
*                It is used by SWING
*
*  Environment:  VMS
*
*  Author:       Eric Andresen of General Research Corporation
*
*  Date:         24-SEP-1986
*
*-----------------------------------------------------------------------

      subroutine pd_get_choice( board_id, keyboard, width,
     .                          pd_choices, choice, code )

*     PD_GET_CHOICE( BOARD_ID, KEYBOARD, WIDTH, PD_CHOICES, CHOICE, CODE )
*
*     BOARD_ID       INTEGER*4
*     KEYBOARD       INTEGER*4
*     WIDTH          INTEGER*4
*     PD_CHOICES     RECORD /PD_CHOICE_TYPE/  (PULLDOWN.CMN)
*     CHOICE         CHARACTER*(PD_MAX_CHOICE_LEN)
*     CODE           INTEGER*4
*
      include 'pulldown.cmn/List'

      integer   num_choice, save_choice, code, keyboard, width
      integer   board_id
      logical   do_bar
      character choice*(PD_MAX_CHOICE_LEN)
      record /pd_choice_type/ pd_choices

      do_bar = .true.
      num_choice = 1

C     LOOP UNTIL A VALID EXIT OCCURS
      do while ( do_bar )

C        GET A CHOICE FROM THE BAR
         call pd_bar_choice( keyboard, num_choice, pd_choices )

         save_choice = 0
         do_bar = .false.

C        AS LONG AS THE USER IS CHOOSING LISTS FROM THE BAR
         do while ( save_choice .ne. num_choice .and.
     .              pd_choices.ptr(num_choice) .ne. 0 )
            save_choice = num_choice
            call pd_list_choice( board_id, keyboard, width, num_choice,
     .                           %val(pd_choices.ptr(num_choice)),
     .                           choice, code, do_bar )
         end do

C        IF A CHOICE HAS BEEN MADE
         if ( .not. do_bar ) then

C           IF ITS ONLY A CHOICE FROM THE BAR BECAUSE THERE WAS NO
C           ASSOCIATED LIST
            if ( save_choice .eq. 0 .and. num_choice .ne. 0 ) then
               choice = pd_choices.choice(num_choice)
               code = pd_choices.code(num_choice)

C              IF NO CHOICE WAS MADE
               else if ( save_choice .eq.0 .and. num_choice .eq.0 ) then
               choice = ' '
               code = -1
               end if

C              OTHERWISE A CHOICE WAS MADE FROM THE CALL TO
C              pd_list_choice

            end if

      end do

      return
      end
870303:12:53:38