PORTIA@engvax.scg.hac.COM.UUCP (08/14/87)
$ show default
$ check_sum = 1377003600
$ write sys$output "Creating 4.FOR"
$ create 4.FOR
$ DECK/DOLLARS="$*$*EOD*$*$"
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)'
INCLUDE '($XABDEF)'
INCLUDE '($XABPRODEF)'
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
subroutine move_file
c Craig Young 3-AUG-87
c This subroutine controls the moving of the current file to another
c directory. The new host directory is determined in the same manner
c as in the subroutine Rename_Directory.
include 'swing.cmn'
include '($smgdef)'
character file*255, message*255
integer istat, lib$rename_file
integer from_num, from_line, from_level, old_line, old_level
integer old_file, old_top, old_bottom
integer ikey, len_message, ii, jj
logical finished
c Check if current file is a directory. If so, abort move.
istat = index( fnode(file_num).spec(1:), '.DIR;1' )
if ( istat .eq. 0 ) then
old_file = file_num
old_top = top_file_line
old_bottom = bottom_file_line
from_num = node_num
from_line = cur_line
from_level = cur_level
node(from_num).rend = smg$m_reverse + smg$m_blink
call smg$unpaste_virtual_display( file_window, board_id )
call smg$change_rendition( window2, from_line, from_level*17+1,
. 1, 12, node(from_num).rend )
call print_message( 'Travel to new host directory and press '//
. 'RETURN - Press any other key to abort',0)
call smg$set_cursor_abs( window2, from_line, from_level*17+1 )
finished = .false.
do while ( .not. finished )
call smg$read_keystroke( keyboard, ikey )
old_line = cur_line
old_level = cur_level
old_rend = node(node_num).rend
if ( ikey .eq. smg$k_trm_cr .or.
. ikey .eq. smg$k_trm_enter ) then
finished = .true.
else if ( ikey .eq. smg$k_trm_up ) then
ii = cur_level
jj = cur_line - 1
do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 )
jj = jj - 1
end do
if ( jj .ge. 1 ) cur_line = jj
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_down ) then
ii = cur_level
jj = cur_line + 1
do while( node_pointer(ii,jj) .eq. 0 .and.
. jj .le. num_lines )
jj = jj + 1
end do
if ( jj .le. num_lines ) cur_line = jj
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_right ) then
ii = cur_level + 1
jj = cur_line
do while( node_pointer(ii,jj) .eq. 0 .and.
. ii .le. MAX_LEVELS )
ii = ii + 1
end do
if ( ii .le. MAX_LEVELS ) cur_level = ii
call update_screen( old_line, old_level )
else if ( ikey .eq. smg$k_trm_left .and.
. cur_level .ge. 1 ) 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
cur_level = ii
cur_line = jj
end if
call update_screen( old_line, old_level )
else
finished = .true.
end if
call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )
end do
node(from_num).rend = smg$m_reverse
call smg$change_rendition( window2, from_line, from_level*17+1,
. 1, 12, node(from_num).rend )
if ( ikey .eq. smg$k_trm_cr .or.
. ikey .eq. smg$k_trm_enter ) then
istat = lib$rename_file( fnode(old_file).spec,
. '[]'//fnode(old_file).name )
if ( istat ) then
call print_message( 'File has been moved', 0 )
else
call sys$getmsg( %val(istat), len_message, message,
. %val(1), )
call print_message( message(1:len_message), 0 )
end if
else
call smg$erase_display( window3 )
end if
call load_display
cur_line = node(from_num).line
cur_level = node(from_num).level
call update_screen( cur_line, cur_level )
call load_files
if ( old_file .le. num_files ) then
file_num = old_file
else
file_num = 1
end if
top_file_line = old_top
bottom_file_line = old_bottom
call smg$paste_virtual_display( file_window, board_id, 10, 40)
call update_file_window
else
call print_message('Cannot move a directory with the filer.',0)
end if
return
end
subroutine move_node( num, parent )
include 'swing.cmn'
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
subroutine pd_bar_choice( keyboard, num_choice, pd_choices )
implicit none
include '($smgdef)'
include 'pulldown.cmn'
integer pos, new_pos, key, num_choice, keyboard, ii
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
subroutine pd_draw_bar( board_id )
* PD_DRAW_BAR( BOARD_ID )
*
* BOARD_ID INTEGER*4
*
implicit none
include 'pulldown.cmn'
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
*=======================================================================
*
* 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 )
implicit none
* 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'
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
subroutine pd_list_choice( board_id, keyboard, width, num_choice,
. pd_choices, choice, code, do_bar)
implicit none
include '($smgdef)'
include 'pulldown.cmn'
record /pd_choice_type/ pd_choices
integer smg$create_virtual_display
integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES), code, istat
integer start_pos, pd_list_id, atts(PD_MAX_CHOICES), num_choice
integer pos, new_pos, key, width, keyboard, board_id
logical exit, do_bar
character choice*(PD_MAX_CHOICE_LEN)
do_bar = .false.
C FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
ii = 1
max_cell = 0
do while ( ii .le. pd_choices.number )
call str$trim( pd_choices.choice(ii), pd_choices.choice(ii),
. lens(ii) )
max_cell = max( max_cell, lens(ii) )
ii = ii + 1
end do
ii = ii - 1
C CREATE THE VIRTUAL DISPLAY FOR THE LIST
istat = smg$create_virtual_display( ii, max_cell, pd_list_id,
. smg$m_border, smg$m_reverse )
C PUT THE CHOICES IN THE LIST
do jj = 1, ii
if ( pd_choices.ptr(jj) .eq. 0 ) then
call smg$put_chars( pd_list_id,
. pd_choices.choice(jj)(1:max_cell),
. jj, 1 )
atts(jj) = 0
else
call smg$put_chars( pd_list_id,
. pd_choices.choice(jj)(1:max_cell),
. jj, 1,, smg$m_underline )
atts(jj) = smg$m_underline
end if
end do
start_pos = 1 + (pd_cell_size*(num_choice-1))
if ( start_pos + max_cell .gt. width ) then
start_pos = width - max_cell + 1
end if
call smg$begin_pasteboard_update( board_id )
call smg$paste_virtual_display( pd_list_id, board_id, 2,
. start_pos )
call smg$repaste_virtual_display( pd_bar_id, board_id, 1, 1 )
call smg$end_pasteboard_update( board_id )
C GET A CHOICE FROM THE LIST
exit = .false.
key = 0
pos = 1
new_pos = 1
C SET THE RENDITION OF THE FIRST CHOICE
call smg$change_rendition( pd_list_id, 1, 1, 1,
. max_cell, smg$m_bold + atts(1) )
do while ( key .ne. smg$k_trm_enter .and.
. key .ne. smg$k_trm_cr .and. .not. exit )
call smg$set_cursor_abs( pd_list_id, pos, 1 )
call smg$read_keystroke( keyboard, key )
if ( key .eq. smg$k_trm_up ) then
if ( pos .gt. 1 ) then
new_pos = pos - 1
else
do_bar = .true.
exit = .true.
end if
else if ( key .eq. smg$k_trm_down ) then
if ( pos .lt. ii ) new_pos = pos + 1
else if ( key .eq. smg$k_trm_left ) then
if ( num_choice .gt. 1 ) num_choice = num_choice - 1
do_bar = .true.
exit = .true.
else if ( key .eq. smg$k_trm_right ) then
if ( num_choice .lt. pd_num_choices )
. num_choice = num_choice + 1
do_bar = .true.
exit = .true.
else if ( key .eq. smg$k_trm_ctrlz ) then
exit = .true.
end if
if ( new_pos .ne. pos ) then
call smg$change_rendition( pd_list_id, pos, 1, 1,
. max_cell, atts(pos))
call smg$change_rendition( pd_list_id, new_pos, 1, 1,
. max_cell,
. smg$m_bold+atts(new_pos) )
end if
pos = new_pos
end do
call smg$unpaste_virtual_display( pd_list_id, board_id )
if ( exit ) then
choice = ' '
code = -1
else
choice = pd_choices.choice(pos)
code = pd_choices.code(pos)
end if
return
end
subroutine pd_load_bar( width, pd_choices )
* PD_LOAD_BAR( WIDTH, PD_CHOICES )
*
* WIDTH INTEGER*4
* PD_CHOICES RECORD /PD_CHOICE_TYPE/ (PULLDOWN.CMN)
*
implicit none
include '($smgdef)'
include 'pulldown.cmn'
integer smg$create_virtual_display, smg$change_virtual_display
integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES)
integer start_pos, off_set, width, istat
record /pd_choice_type/ pd_choices
C FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
ii = 1
max_cell = 0
do while ( ii .le. pd_choices.number )
call str$trim( pd_choices.choice(ii), pd_choices.choice(ii),
. lens(ii) )
max_cell = max( max_cell, lens(ii) )
ii = ii + 1
end do
ii = ii - 1
C CREATE THE VIRTUAL DISPLAY FOR THE BAR
if ( pd_bar_id .eq. 0 ) then
istat = smg$create_virtual_display( 1, width, pd_bar_id,,
. smg$m_reverse )
else
call smg$erase_display( pd_bar_id )
istat = smg$change_virtual_display( pd_bar_id, 1, width,
. pd_bar_id,, smg$m_reverse )
end if
C FIGURE OUT THE LENGTH OF EACH CELL
C IF THERE IS ROOM ENOUGH FOR ALL OF THE CHOICES AS IS
if ( (ii*max_cell) .le. width ) then
pd_cell_size = min( 16, width / ii )
C MAKE IT 16 OR LESS
else
pd_cell_size = min( 16, width / max_cell )
end if
C PUT THE CHOICES IN THE MENU
do jj = 1, ii
start_pos = 1 + (pd_cell_size*(jj-1))
off_set = max( 1, pd_cell_size-lens(jj)) / 2
call smg$put_chars( pd_bar_id,
. pd_choices.choice(jj)(1:lens(jj)),,
. start_pos + off_set )
end do
pd_num_choices = ii
return
end
subroutine pd_undraw_bar( board_id )
* PD_UNDRAW_BAR( BOARD_ID )
*
* BOARD_ID INTEGER*4
*
implicit none
include 'pulldown.cmn'
integer board_id
call smg$unpaste_virtual_display( pd_bar_id, board_id )
return
end
subroutine print_file
c Craig Young 3-AUG-87
c This subroutine sends the current file to the printer as specified
c by Swing$Print or defaults to $Print. The terminal is not attached
c to the spawned process so use of swing can continue.
include 'swing.cmn'
include '($ssdef)'
include '($clidef)'
character string*255, logical_name*50, file*50
integer istat, len_string, len_file
integer*4 translate_logical
c Check if current file is a directory. If so, abort print.
istat = index( fnode(file_num).spec(1:), '.DIR;1' )
if ( istat .eq. 0 ) then
call print_message( ' ', 0 )
call smg$set_cursor_abs( window3, 2, 1 )
call str$trim( file, fnode(file_num).spec, len_file )
logical_name = 'SWING$PRINT' !Check for user's printer
istat = translate_logical( logical_name, string )
if ( istat .eq. ss$_normal ) then
call str$trim( string, string, len_string )
call lib$spawn( string(1:len_string)
. //'/noidentify/nonotify '
. //file(1:len_file),,,cli$m_nowait)
else
call lib$spawn( '$print/noidentify/nonotify '
. //file(1:len_file),,,cli$m_nowait)
end if
call print_message( 'Sent file to printer.', 0 )
else
call print_message( 'Cannot print a directory.', 0 )
end if
return
end
$*$*EOD*$*$
$ checksum 4.FOR
$ if checksum$checksum .ne. check_sum then -
$ write sys$output "Checksum failed, file probably corrupted"
$ exitfede@ethz.UUCP (F. Bonzanigo) (08/31/87)
The string "file" in the subroutine PRINT_FILE is too short.
Therefore the command PRINT in the Filer fails if the string containing
the directory path and the file name is too long. I declared
character ... file*255 (instead of "file*50")
in the subroutine print_file (which is in the file 4.for), as it has been
done in move_file.
Federico Bonzanigo
Institut fuer Elektronik
Swiss Federal Institute of Technology (ETH)
CH-8092 Zurich, Switzerland
EAN: bonzanigo@nimbus.ethz.ch
EARN/BITNET: BONZANIGO@CZHETH5A
EUNET/UUCP: ...!mcvax!cernvax!ethz!fede
Phone: +41 (1) 256-5134 (+ = whatever you have to dial
Telefax: +41 (1) 251-2172 to phone outside your country)
Telex: 81 73 79