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_Record49: Read/End_Of_File=EOF49 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record49
$EOF49: 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
X Program SWING
X Implicit NONE
X Character Program_Name*5/'SWING'/
X
X! Nomenclature: ea Eric Andresen
X! mb Michael Bednarek (u3369429@murdu.oz.au)
X! ms Mike Strasser (STRASSER@RSBS0.ANU.au)
X* Version: 1-001 ea
X! 1-002 mb Heavy de-bugging and "Implicit NONE" everywhere
X! 27-Apr-87 mb implemented "Next/Previous Screen"
X! removed calls to set_notab & reset_terminal
X! 01-May-87 mb Fixed bug re: multiple width changes
X Character Version*9
X 1 /'04-May-87'/ ! mb added M.Strasser's ISADIR
X
X* Abstract: SWING is a VMS utility for displaying and manipulating
X* VMS directory trees.
X*
X* Environment: VMS
X*
X* Author: Eric Andresen of General Research Corporation
X*
X* Date: 24-SEP-1986
X
X! Bugs: Major For reasons unknown, one cannot change more than once the
X! width of the screen. If one creates a directory so that the
X! width is set to 132 and then deletes it again, SWING crashes.
X! Or, if one has already a structure which requires a width of
X! 132 and then deletes directories so that the display changes to
X! 80, and then creates again a directory so that the display
X! has to change to 132 again, SWING will crash, too.
X! 01-May-87 This behaviour disappeared when 6 calls to SMG$Erase_Display
X! in Load_Display were removed.
X
X! Minor When SWING has to alter the width of the screen as compared
X! to what it was when the program started, the SMG-routines will
X! restore the original screen width and the cursor is left at the
X! top of the screen.
X
X! When a structure is deleted which is larger than the current
X! display, the window is not scrolled to show the progress
X! of deleting the structure.
X
X*-----------------------------------------------------------------------
X include '($smgdef)/List'
X include 'swing.cmn/List'
X
X Integer*4 ikey,old_level,old_line,isave,code,code_type,ii,jj,
X 1 Swing_Err_Hdl,Old_Handler,LIB$Establish
X logical crt,finished
X character key,choice*(PD_MAX_CHOICE_LEN)
X External Swing_Err_Hdl
X
X Write (*,*) Program_Name,' ',Version
X
X if (.not.crt()) call print_message('You must use a DEC CRT terminal',1)
X
X! Establish a Condition Handler
X Old_Handler=LIB$Establish(Swing_Err_Hdl)
X
X call load_nodes
X call define_smg_layout
X call load_display
X call draw_screen
X
X do while (.not.finished)
X
X call smg$read_keystroke(keyboard,ikey)
X
X call print_message(' ',0)
X
X old_line=cur_line
X old_level=cur_level
X old_rend=node(node_num).rend
X
X! Pulldown Menu
X if (ikey.eq.smg$k_trm_do .or. ikey.eq.smg$k_trm_ctrlp) then
X call pd_get_choice(board_id,keyboard,width,pull_choices,choice,code)
X code_type=code/10
X else
X code_type=0
X code=0
X end if
X
X if (ikey.eq.smg$k_trm_ctrlz.or.
X 1 ikey.eq.smg$k_trm_lowercase_x.or.
X 1 ikey.eq.smg$k_trm_uppercase_x.or.
X 1 ikey.eq.smg$k_trm_lowercase_e.or.
X 1 ikey.eq.smg$k_trm_uppercase_e.or.
X 1 ikey.eq.SMG$K_TRM_LowerCase_q.or.
X 1 ikey.eq.SMG$K_TRM_UpperCase_Q.or.
X 1 ikey.eq.SMG$K_TRM_F10.or.
X 1 ikey.eq.smg$k_trm_enter.or.
X 1 code.eq.91) 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! find the next line upwards with a node_pointer
X do while (jj.ge.1 .and. node_pointer(ii,jj).eq.0)
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 (jj.le.num_lines .and. node_pointer(ii,jj).eq.0)
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_Prev_Screen) then
X jj=MAX(top_line-20,1)
X ii=0
X! find the first level with a pointer
X Do while (ii.le.MAX_LEVELS .and. node_pointer(ii,jj).eq.0)
X ii=ii+1
X End Do
X cur_line=jj
X cur_level=ii
X Call Update_Screen(old_line,old_level)
X
X else If (ikey.eq.SMG$K_TRM_Next_Screen) then
X jj=MIN(bottom_line+20,num_lines)
X ii=0
X! find the first level with a pointer
X Do while (ii.le.MAX_LEVELS .and. node_pointer(ii,jj).eq.0)
X ii=ii+1
X End Do
X cur_line=jj
X cur_level=ii
X Call Update_Screen(old_line,old_level)
X
X else if (cur_level.lt.MAX_LEVELS .and. ikey.eq.smg$k_trm_right) then
X ii=cur_level+1
X jj=cur_line
X do while(ii.le.MAX_LEVELS .and. node_pointer(ii,jj).eq.0)
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 (cur_level.gt.0 .and. ikey.eq.smg$k_trm_left) then
X ii=cur_level-1
X jj=cur_line
X do while(jj.ge.1 .and. node_pointer(ii,jj).eq.0)
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 if (code_type.eq.1 .or.
X 1 ikey.eq.smg$k_trm_lowercase_c .or.
X 1 ikey.eq.smg$k_trm_uppercase_c) then
X call create_directory(code)
X
X else if (code_type.eq.2 .or.
X 1 ikey.eq.smg$k_trm_lowercase_r .or.
X 1 ikey.eq.smg$k_trm_uppercase_r) then
X call rename_directory(20)
X
X else if (code_type.eq.3 .or.
X 1 ikey.eq.smg$k_trm_lowercase_m .or.
X 1 ikey.eq.smg$k_trm_uppercase_m) then
X call rename_directory(30)
X
X else if (code_type.eq.4 .or.
X 1 ikey.eq.smg$k_trm_lowercase_d .or.
X 1 ikey.eq.smg$k_trm_uppercase_d) then
X call delete_directory(code)
X
X else if (code_type.eq.5 .or.
X 1 ikey.eq.smg$k_trm_lowercase_p .or.
X 1 ikey.eq.smg$k_trm_uppercase_p) then
X call hardcopy(code)
X
X else if (code_type.eq.6 .or.
X 1 ikey.eq.smg$k_trm_lowercase_s .or.
X 1 ikey.eq.smg$k_trm_uppercase_s) then
X call record_structure(.true.)
X
X else if (code_type.eq.7 .or.
X 1 ikey.eq.smg$k_trm_lowercase_o .or.
X 1 ikey.eq.smg$k_trm_uppercase_o) then
X call change_options(71)
X
X else if (code_type.eq.8 .or.
X 1 ikey.eq.smg$k_trm_pf2 .or.
X 1 ikey.eq.smg$k_trm_help .or.
X 1 ikey.eq.smg$k_trm_lowercase_h .or.
X 1 ikey.eq.smg$k_trm_uppercase_h) then
X call help(code)
X end if
X
X call smg$set_cursor_abs(window2,cur_line,cur_level*17+1)
X
X end do
X
X Call Lib$Establish(%VAL(Old_Handler)) ! Establish previous Handler
X call exit_swing
X
X end
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record50: Read/End_Of_File=EOF50 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record50
$EOF50: 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 Swing_Err_HDL (SigArgs,MechArgs)
X Implicit NONE
X
X Include 'swing.cmn/List'
X
X Integer*4 SigArgs(*),MechArgs(*)
X External SS$_Resignal
X
X Call SMG$Set_Cursor_Abs(window3,1,1)
X Call SMG$Delete_Pasteboard(board_id,0)
X
X! Now re-signal the error
X Swing_Err_Hdl=%LOC(SS$_Resignal)
X
X End
$ Name=File'nF
$ Write SYS$Output "creating ",Name
$ Open/Write Out 'Name
$ Open/Read In VMS_SHAR_DUMMY.DUMMY
$Next_Record51: Read/End_Of_File=EOF51 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record51
$EOF51: 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 update_screen(old_line,old_level)
X Implicit NONE
X
X include '($smgdef)/List'
X include 'swing.cmn/List'
X
X integer old_line,old_level,sys$setddir,ii,istat
X
X node_num=node_pointer(cur_level,cur_line)
X
X call smg$begin_pasteboard_update(board_id)
X
X call smg$change_rendition(window2,old_line,old_level*17+1,1,12,
X 1 old_rend)
X call smg$change_rendition(window2,cur_line,cur_level*17+1,1,12,
X 1 smg$m_bold+node(node_num).rend)
X
X call update_window1
X call smg$end_pasteboard_update(board_id)
X
X if (cur_line.gt.bottom_line) then
X do ii=bottom_line+1,cur_line
X call smg$move_virtual_display(window2,board_id,23-ii,1)
X end do
X top_line=cur_line-19
X bottom_line=cur_line
X
X else if (cur_line.lt.top_line) then
X do ii=top_line-1,cur_line,-1
X call smg$move_virtual_display(window2,board_id,4-ii,1)
X end do
X top_line=cur_line
X bottom_line=cur_line+19
X end if
X
X istat=sys$setddir(node(node_num).spec,%val(0),%val(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_Record52: Read/End_Of_File=EOF52 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record52
$EOF52: 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 update_window1
X Implicit NONE
X
X include '($smgdef)/List'
X include 'swing.cmn/List'
X
X integer start
X
X if (use_window1) then
X start=(width-(len_disk+node(node_num).length))/2
X if (start.le.0) start=1
X
X call smg$erase_line(window1,1,1)
X call smg$put_chars(window1,
X 1 disk(1:len_disk)//node(node_num).spec(1:node(node_num).length),
X 1 1,start,,smg$m_underline)
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_Record53: Read/End_Of_File=EOF53 In Record
$ Write Out F$Extract(1,255,Record)
$ Goto Next_Record53
$EOF53: 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; ISADIR routine by Mike Strasser 1987. It is to be called from FORTRAN as
X;
X; STATUS = ISADIR( FILE )
X;
X; Where FILE is a character string containing a file name.
X;
X; The return value is 1 (SS$_NORMAL) if FILE is a directory, and 0 if
X; it isn't, but otherwise OK. If an error is encountered along the way,
X; processing stops and its status value is returned
X;
X; The $OPEN macro uses the option user file open. This is a "Clayton's"
X; open, and no further RMS processing is allowed on the file. It does
X; count against the process' open file quota, however, and while it cannot
X; be $CLOSED, the channel assigned in the $OPEN must be $DEASSGNed.
X;
X; References:
X;
X; $FAB, $NAM and $OPEN macros RMS Ref. Man.
X; $DASSGN macro System Services Man.
X; FIBs and Attribute Control Block I/O User's Ref. Man.: ACP-QIO I'face
X
X
X .Title ISADIR Is this a directory file?
X .Ident /1.02/
X
X .Library "SYS$LIBRARY:LIB.MLB" ;Get $FCHDEF from here
X
X .NoCross
X
X $ATRDEF ;File attributes def'ns
X $FCHDEF ;File characteristic bits def'ns
X $FIBDEF ;File Info Block offsets
X $IODEF ;I/O function codes def'ns
X $RMSDEF ;RMS status codes def'ns
X $SSDEF ;System service codes def'ns
X
X .Cross
X
X .Psect DATA NOEXE, RD, WRT, PIC, NOSHR, PAGE
X
X; Call the $FAB macro to set up a FAB here. File name to be included later
X
XFAB: $FAB FOP=<UFO>, - ;User file open option
X NAM=NAM ;Address of NAM block
XNAM: $NAM ;Set up NAM block here
X
X; FIB descriptor and FIB
X
XFIB_DESC: .Long FIB_END - FIB ;Length of the FIB
X .Address FIB ;Address of the FIB
X
XFIB: .Long 0 ;FIB$L_ACCTL and FIB$B_WSIZE
XFID: .Blkw 3 ;FIB$W_FID: file ID, 3 words
XDID: .Blkw 3 ;FIB$W_DID: directory ID, 3 words
X .Blkl ;FIB$L_WCC: wildcard context
X .Word FIB$M_FINDFID ;FIB$W_NMCTL: file name control bits
XFIB_END: ;Mark end of the FIB
X
X; Attribute control block (zero-terminated)
X
XATTR_LIST: .Word ATR$S_UCHAR, ATR$C_UCHAR ;4 byte file characteristics
X .Address UCHAR ;To go here
X .Long 0 ;This marks the end of the list
X
XUCHAR: .Blkl ;File attributes to go here
XIOSB: .Blkq ;IO status block for IO$_ACCESS
X
X .Psect CODE EXE, RD, NOWRT, PIC, SHR, PAGE
X
X .Entry ISADIR, 0
X
X; Get the file name from the agument list (passed by descriptor)
X
X MOVL 4(AP), R0 ;Address of descriptor -> R0
X MOVL 4(R0), FAB+FAB$L_FNA ;Address of string -> FAB block
X MOVB (R0), FAB+FAB$B_FNS ;Length of string -> FAB block
X
X $OPEN FAB=FAB ;Call to open file
X BLBS R0, 10$ ;Bomb out if error
X RET
X
X; Copy file and directory info from NAM block into the FIB block
X
X10$: MOVL NAM+NAM$W_FID, FID ;Copy the FID (file)
X MOVW NAM+NAM$W_FID+4, FID+4
X MOVL NAM+NAM$W_DID, DID ;Copy the DID (directory)
X MOVW NAM+NAM$W_DID+4, DID+4
X
X MOVAL ATTR_LIST, R1 ;Address of Attr. list to R1
X
X $QIOW_S CHAN=FAB+FAB$L_STV, - ;I/O on this channel
X FUNC=#IO$_ACCESS, - ;Access the file
X IOSB=IOSB, - ;I/O status here
X P1=FIB_DESC, - ;Address of FIB descriptor
X P5=R1 ;Address of return attributes
X BLBC R0, 30$ ;Bomb out via deassign if error
X MOVZWL IOSB, R0 ;Get status in more detail
X BLBC R0, 30$ ;Bomb out via deassign if error
X
X $DASSGN_S -
X CHAN=FAB+FAB$L_STV ;Deassign the channel
X BLBC R0, 20$ ;Bomb out if error
X
X; Directory check: if the FCH$V_DIRECTORY bit is set, it's a dir
X
X MOVL #SS$_NORMAL, R0
X BBS #FCH$V_DIRECTORY, UCHAR, 20$
X MOVL #0, R0
X
X20$: RET
X
X30$: PUSHL R0 ;Push error status code
X $DASSGN_S -
X CHAN=FAB+FAB$L_STV ;Deassign the channel
X POPL R0 ;This is the code we want to return
X RET
X
X .End