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


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

$Part10:
$ File_is="SWING_6.FOR"
$ Check_Sum_is=746020597
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X      INTEGER*4 FUNCTION MODIFY_FILE_PROT ( FILE, PROT, CODE )
X
XC     Modifies  the protection  on a specified  file.  The file's access
XC     control list, if it  has one, is not modified.  The status of  the
XC     operation is returned as a function value.
X
XC     This routine will fail if the protection on the file (prior to the
XC     modification) is such that we do not have read and write access to
XC     it.  It will also fail if the file has already been opened without
XC     write-shareability.
X
XC     Greg Janee, 19-MAR-1986
X
XC-----------------------------------------------------------------------
X
XC     Arguments:
XC
XC     FILE      type:      character string
XC               access:    read only
XC               mechanism: by descriptor, fixed-length descriptor
XC
XC     The filename of  the file whose  protection is to be modified.  If
XC     the string is larger than 255 bytes, only the first 255  bytes are
XC     used.
XC
XC     PROT      type:      unsigned word
XC               access:    read only
XC               mechanism: by reference
XC
XC     The bit mask  that is to replace  or modify the  file's protection
XC     bits.  The mask  should be  specified in  the format  described by
XC     section 12.13 of the VAX Record Management Services Reference Man-
XC     ual.
XC
XC     CODE      type:      signed longword integer
XC               access:    read only
XC               mechanism: by reference
XC
XC     The type of modification to be performed on  the file's protection
XC     bits.  A  value of 0 indicates the  bits are to be replaced by the
XC     PROT argument;  values  1, 2, and 3 indicate  the bits  are  to be
XC     ANDed, inclusive-ORed, or  exclusive-ORed with the  PROT argument,
XC     respectively.  The  protection  bits  are left  unchanged  for all
XC     other values of this argument.
X
XC=======================================================================
X
X      IMPLICIT  NONE
X
X      INCLUDE   '($FABDEF)'
X      INCLUDE   '($XABDEF)'
X      INCLUDE   '($XABPRODEF)'
X
XC     We have to define our own structure to access a XABPRO because DEC
XC     is too stupid to define theirs correctly.
X
X      STRUCTURE /XABPRO/
X         UNION
X            MAP
X               RECORD /XABDEF/     A
X            END MAP
X            MAP
X               RECORD /XABPRODEF1/ B
X            END MAP
X         END UNION
X      END STRUCTURE
X
X      CHARACTER FILE*(*)
X      INTEGER*2 PROT
X      INTEGER*4 CODE
X
X      RECORD    /FABDEF/ FAB
X      RECORD    /XABPRO/ XAB
X
X      INTRINSIC JMIN0
X      INTRINSIC LEN
X      EXTERNAL  LIB$INSV
X      EXTERNAL  LIB$MOVC5
X      EXTERNAL  SYS$CLOSE
X      INTEGER*4 SYS$CLOSE
X      EXTERNAL  SYS$OPEN
X      INTEGER*4 SYS$OPEN
X
XC-----------------------------------------------------------------------
X
XC     First initialize and  link a FAB and XAB.  Note that  if we do not
XC     open the  file with some sort  of write access the protection will
XC     not be changed.
X
X      CALL LIB$MOVC5 ( 0, 0, 0, FAB$C_BLN, FAB )
X
X      FAB.FAB$B_BID = FAB$C_BID
X      FAB.FAB$B_BLN = FAB$C_BLN
X      FAB.FAB$B_FAC = FAB$M_PUT
X      FAB.FAB$L_FNA = %LOC( FILE )
X      CALL LIB$INSV ( JMIN0( LEN(FILE), 255 ), 0, 8, FAB.FAB$B_FNS )
X
XC     RMS will balk if the  file has been opened by  someone else.  With
XC     the following SHR options we'll at least get through the case when
XC     the file has been opened write-shared.
X
X      FAB.FAB$B_SHR = FAB$M_SHRPUT .OR. FAB$M_SHRGET .OR.
X     .                FAB$M_SHRDEL .OR. FAB$M_SHRUPD .OR. FAB$M_UPI
X
X      FAB.FAB$L_XAB = %LOC( XAB )
X
X      CALL LIB$MOVC5 ( 0, 0, 0, XAB$C_PROLEN, XAB )
X
X      XAB.A.XAB$B_BLN = XAB$C_PROLEN
X      XAB.A.XAB$B_COD = XAB$C_PRO
X
XC-----------------------------------------------------------------------
X
XC     There is  no RMS service to  change file protections.  To do so we
XC     open the file with write access and then close  it with a new pro-
XC     tection mask.
X
X      MODIFY_FILE_PROT = SYS$OPEN( FAB )
X      IF ( .NOT.MODIFY_FILE_PROT ) RETURN
X
X      IF     ( CODE .EQ. 0 ) THEN
X         XAB.B.XAB$W_PRO =                       PROT
X      ELSEIF ( CODE .EQ. 1 ) THEN
X         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .AND. PROT
X      ELSEIF ( CODE .EQ. 2 ) THEN
X         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .OR.  PROT
X      ELSEIF ( CODE .EQ. 3 ) THEN
X         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .XOR. PROT
X      END IF
X
X      MODIFY_FILE_PROT = SYS$CLOSE( FAB )
X      RETURN
X
XC=======================================================================
X
X      END
X      subroutine move_file
X
Xc     Craig Young               3-AUG-87
X
Xc     This subroutine controls the moving of the current file to another
Xc     directory.  The new host directory is determined in the same manner
Xc     as in the subroutine Rename_Directory.
X
X      include    'swing.cmn'
X      include    '($smgdef)'
X
X      character  file*255, message*255
X      integer    istat, lib$rename_file
X      integer    from_num, from_line, from_level, old_line, old_level
X      integer    old_file, old_top, old_bottom
X      integer    ikey, len_message, ii, jj
X      logical    finished
X
Xc     Check if current file is a directory.  If so, abort move.
X
X      istat = index( fnode(file_num).spec(1:), '.DIR;1' )
X
X      if ( istat .eq. 0 ) then
X         old_file = file_num
X         old_top =  top_file_line
X         old_bottom = bottom_file_line
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$unpaste_virtual_display( file_window, board_id )
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 host directory and press '// 
X     .                       'RETURN - Press 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
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 ) 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            istat = lib$rename_file( fnode(old_file).spec,
X     .                               '[]'//fnode(old_file).name )
X
X            if ( istat ) then
X               call print_message( 'File has been moved', 0 )
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         else
X            call smg$erase_display( window3 )
X            end if
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 load_files
X
X         if ( old_file .le. num_files ) then
X            file_num = old_file
X         else
X            file_num = 1
X            end if
X         top_file_line = old_top
X         bottom_file_line = old_bottom
X
X         call smg$paste_virtual_display( file_window, board_id, 10, 40)
X         call update_file_window
X
X      else
X         call print_message('Cannot move a directory with the filer.',0)
X         end if
X
X      return
X      end
X      subroutine move_node( num, parent )
X   
X      include    'swing.cmn'
X
X      logical    found_node, greater
X      integer    num, ii, jj, parent, ptr(0:7)
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. num ) then
X            found_node = .true.
X            node(ii).sister = node(num).sister
X
X            else if ( node(ii).child .eq. num ) then
X            found_node = .true.
X            node(ii).child = node(num).sister
X            end if
X         ii = ii + 1
X      end do
X
X      if ( .not. found_node ) return
X
X      node(num).sister = 0
X
X      if ( parent .eq. 0 ) 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            parent = node_pointer(ii,jj)
X            else
X            parent = 1
X            end if
X         end if
X
X      if ( node(parent).child .eq. 0 ) then
X         node(parent).child = num
X
X         else
X         ii = node(parent).child
X         if ( node(num).name .lt. node(ii).name ) then
X            node(num).sister = node(parent).child
X            node(parent).child = num
X
X            else
X            greater = .true.
X            do while ( greater )
X               if ( node(ii).sister .eq. 0 ) then
X                  node(ii).sister = num
X                  greater = .false.
X
X                  else 
X                  jj = ii
X                  ii = node(ii).sister
X                  if ( node(num).name .lt. node(ii).name ) then
X                     node(jj).sister = num
X                     node(num).sister = ii
X                     greater = .false.
X                     end if
X                  end if                  
X            end do
X            end if            
X         end if
X     
X      ptr(0) = num
X
X      call change_spec( parent, ptr(0) )
X      ptr(1) = node(ptr(0)).child
X      do while( ptr(1) .ne. 0 )
X        call change_spec( ptr(0), ptr(1) )
X        ptr(2) = node(ptr(1)).child
X        do while( ptr(2) .ne. 0 ) 
X          call change_spec( ptr(1), ptr(2) )
X          ptr(3) = node(ptr(2)).child
X          do while( ptr(3) .ne. 0 ) 
X            call change_spec( ptr(2), ptr(3) )
X            ptr(4) = node(ptr(3)).child
X            do while( ptr(4) .ne. 0 ) 
X              call change_spec( ptr(3), ptr(4) )
X              ptr(5) = node(ptr(4)).child
X              do while( ptr(5) .ne. 0 ) 
X                call change_spec( ptr(4), ptr(5) )
X                ptr(6) = node(ptr(5)).child
X                do while( ptr(6) .ne. 0 ) 
X                  call change_spec( ptr(5), ptr(6) )
X                  ptr(7) = node(ptr(6)).child
X                  do while( ptr(7) .ne. 0 ) 
X                    call change_spec( ptr(6), ptr(7) )
X                    ptr(7) = node(ptr(7)).sister
X                  end do
X                  ptr(6) = node(ptr(6)).sister
X                end do
X                ptr(5) = node(ptr(5)).sister
X              end do
X              ptr(4) = node(ptr(4)).sister
X            end do
X            ptr(3) = node(ptr(3)).sister
X          end do
X          ptr(2) = node(ptr(2)).sister
X        end do
X        ptr(1) = node(ptr(1)).sister
X      end do
X
X      return
X      end
$ GoSub Convert_File
$ Goto Part11
