u3369429@murdu.OZ (Michael 'I love VMS' Bednarek) (05/07/87)
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record31: Read/End_Of_File=EOF31 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record31
$EOF31: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine load_display
X Implicit NONE
X
X include '($smgdef)/List'
X include 'swing.cmn/List'
X
X integer ii,jj,kk,level,istat,
X 1 smg$change_pbd_characteristics,
X 1 smg$change_rendition
X
X using_screen=.true.
X
X if (.not.found) then
X cur_level=0
X cur_line=1
X end if
X
X last_level=0
X line=0
X do ii=0,MAX_LEVELS
X last_line(ii)=1
X end do
X
X if (lowest_level.gt.4 .and. width.ne.132) then
X width=132
X call pd_undraw_bar(board_id)
X!!! call smg$erase_display(window1)
X!!! call smg$erase_display(window2)
X!!! call smg$erase_display(window3)
X istat=smg$change_pbd_characteristics(board_id,132,,24)
X call smg$set_display_scroll_region(window3,1,2)
X call pd_load_bar(width,pull_choices)
X call pd_draw_bar(board_id)
X
X else if (lowest_level.le.4.and.width.ne.80) then
X width=80
X call pd_undraw_bar(board_id)
X!!! call smg$erase_display(window1)
X!!! call smg$erase_display(window2)
X!!! call smg$erase_display(window3)
X istat=smg$change_pbd_characteristics(board_id,80,,24)
X call smg$set_display_scroll_region(window3,1,2)
X call pd_load_bar(width,pull_choices)
X call pd_draw_bar(board_id)
X end if
X
X call smg$begin_pasteboard_update(board_id)
X
X call smg$erase_display(window2)
X
X do jj=1,num_lines
X do level=0,MAX_LEVELS
X if (node_pointer(level,jj).ne.0)
X 1 call add_node_to_display(node_pointer(level,jj))
X end do
X end do
X
Xc PUT UNDERLINES ON THE LEAF NODES
X
X!!! do jj=2,num_nodes !!! changed by Michael Bednarek to:
X Do jj=2,num_lines
X do ii=2,MAX_LEVELS
X if (node_pointer(ii ,jj).ne.0 .and.
X 1 node_pointer(ii-1,jj).ne.0 .and.
X 1 node_pointer(ii ,jj-1).ne.0) then
X kk=node_pointer(ii,jj-1)
X node(kk).rend=smg$m_underline+smg$m_reverse
X istat=smg$change_rendition(window2,node(kk).line,
X 1 node(kk).level*17+1,1,12,node(kk).rend)
X end if
X end do
X end do
X
X call smg$end_pasteboard_update(board_id)
X
X if (.not.found) call print_message
X 1 ('The current directory was not found in your save file',0)
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record32: Read/End_Of_File=EOF32 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record32
$EOF32: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine load_nodes
X Implicit NONE
X
X include 'swing.cmn/List'
X
X integer*2 len_root
X integer*4 icontext(MAX_LEVELS),lib$find_file,LIB$SYS_TRNLOG,lTR,ii,jj,
X 1 IsAdir
X character input*255,spec*255,search(0:MAX_LEVELS)*255,TR*255
X
X do ii=1,MAX_LINES
X do jj=0,MAX_LEVELS
X node_pointer(jj,ii)=0
X end do
X end do
X
X call get_location(disk,len_disk,root,len_root)
X
X found=.false.
X lowest_level=0
X last_level=1
X line=0
X num_nodes=0
X node_num=0
X
X! A directory name may be surrounded either by "[]" or "<>".
X ii=INDEX(root,'<')
X If (ii.ne.0) then
X root(ii:ii)='['
X ii=INDEX(root,'>')
X root(ii:ii)=']'
X End If
X
X! Find top-level
X ii=1
X do while (root(ii:ii).ne.'.' .and. root(ii:ii).ne.']')
X ii=ii + 1
X end do
X
X main=root(:ii-1)//']'
X len_main=ii
X spec=main
X
X! Michael Bednarek disabled the next statement:
X!!! if (main.eq.'[000000]')
X!!! 1 call print_message('Master file directory not allowed',1)
X
X! Create a file name for the save file (Michael Bednarek)
X! The rationale behind this is that I don't want to write the SWING.SAV file
X! into other users' directories.
X! If the logical name SWING_SAVE exists,
X If (LIB$SYS_TRNLOG('SWING_SAVE',lTR,TR,,,%VAL(0)).eq.1) then
X! construct a file name like: SWING_SAVE:USERNAME_SWING.SAV
X main(1:len_main+10)='SWING_SAVE:'//main(2:len_main-1)//'_'
X len_main=len_main+10
X End If
X
X ii=0
X if (.not.update .and.
X 1 lib$find_file(main(1:len_main)//'swing.sav',input,ii)) then
X open(unit=1,
X 1 readonly,
X 1 name=main(1:len_main)//'swing.sav',
X 1 status='old',
X 1 carriagecontrol='list',
X 1 access='sequential',
X 1 form='unformatted',
X 1 recl=73,
X 1 organization='sequential',
X 1 recordtype='variable',
X 1 err=99)
X read(1,err=99) num_lines,num_nodes,lowest_level
X
X do ii=1,num_lines
X read(1,err=99) (node_pointer(jj,ii),jj=0,MAX_LEVELS)
X end do
X
X do ii=1,num_nodes
X read(1,err=99) node(ii)
X end do
X
X close(unit=1)
X swing_file_exists=.true.
X
X else
X99 call print_message('Searching directory structure...',0)
X! Start with level 0, obtain something like "[FOOBAR]*.DIR;1" in search(1)
X call append_node(0,spec,search(1))
X
X icontext(1)=0
X do while (lib$find_file(search(1),spec,icontext(1)))
X If (IsAdir(spec)) then
X call append_node(1,spec,search(2))
X icontext(2)=0
X do while (lib$find_file(search(2),spec,icontext(2)))
X If (IsAdir(spec)) then
X call append_node(2,spec,search(3))
X icontext(3)=0
X do while (lib$find_file(search(3),spec,icontext(3)))
X If (IsAdir(spec)) then
X call append_node(3,spec,search(4))
X icontext(4)=0
X do while (lib$find_file(search(4),spec,icontext(4)))
X If (IsAdir(spec)) then
X call append_node(4,spec,search(5))
X icontext(5)=0
X do while (lib$find_file(search(5),spec,icontext(5)))
X If (IsAdir(spec)) then
X call append_node(5,spec,search(6))
X icontext(6)=0
X do while (lib$find_file(search(6),spec,icontext(6)))
X If (IsAdir(spec)) then
X call append_node(6,spec,search(7))
X icontext(7)=0
X do while (lib$find_file(search(7),spec,icontext(7)))
X If (IsAdir(spec)) then
X call append_node(7,spec,search(0))
X End If
X end do
X End If
X call lib$find_file_end(icontext(7))
X end do
X End If
X call lib$find_file_end(icontext(6))
X end do
X End If
X call lib$find_file_end(icontext(5))
X end do
X End If
X call lib$find_file_end(icontext(4))
X end do
X End If
X call lib$find_file_end(icontext(3))
X end do
X End If
X call lib$find_file_end(icontext(2))
X end do
X call lib$find_file_end(icontext(1))
X end if
X
X return
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record33: Read/End_Of_File=EOF33 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record33
$EOF33: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X INTEGER*4 FUNCTION MODIFY_FILE_PROT(FILE,PROT,CODE)
X Implicit NONE
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 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 Manual.
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.
XC=======================================================================
X INCLUDE '($FABDEF)/List'
X INCLUDE '($XABDEF)/List'
X INCLUDE '($XABPRODEF)/List'
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
XC-----------------------------------------------------------------------
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 1 FAB$M_SHRDEL.OR.FAB$M_SHRUPD.OR.FAB$M_UPI
X FAB.FAB$L_XAB=%LOC(XAB)
X CALL LIB$MOVC5 (0,0,0,XAB$C_PROLEN,XAB)
X XAB.A.XAB$B_BLN=XAB$C_PROLEN
X XAB.A.XAB$B_COD=XAB$C_PRO
XC-----------------------------------------------------------------------
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
XC=======================================================================
X END
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record34: Read/End_Of_File=EOF34 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record34
$EOF34: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X subroutine move_node(num,parent)
X Implicit NONE
X
X include 'swing.cmn/List'
X
X logical found_node,greater
X integer num,ii,jj,parent,ptr(0:7)
X
X found_node=.false.
X ii=1
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 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 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 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 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
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record35: Read/End_Of_File=EOF35 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record35
$EOF35: Close Out
$ Close In
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'Name
$ Success=F$Element(Check_Sum'nF.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)
$ Write SYS$ERROR "Checking CHECKSUM. ''Success'"
$ nF=nF+1
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X Options /Extend_Source
X Subroutine One_More_Line (MAX_LINES,ll)
X
X! Add one to ll if this doesn't exceed MAX_LINES
X
X Implicit NONE
X Integer*4 MAX_LINES,ll
X Character ErrMsg*4
X
X ll=ll+1
X If (ll.le.MAX_LINES) then
X Return
X else
X Write (ErrMsg,'(I4)') MAX_LINES ! will crash if MAX_LINES > 9999
X Call Print_Message ('SWING: Too many lines. Maximum: '//ErrMsg,1)
X End If
X End