nagy%warner.hepnet@LBL.GOV (Frank J. Nagy, VAX Wizard & Guru) (02/03/88)
SYASF :== still yet another swing fix
I have modified RENAME_DIRECTORY.FOR to cure another
arithmetic overflow problem. When moving a directory,
should one hit the up-arrow once too often (attempting to
move up beyond highest node in current level), SWING bombs
... the directory doesn't move, but the SWING.SAV file
thinks its gone (a real heart-stopper!).
Lin Winterowd
Fermilab Accelerator Controls
...................... Cut between dotted lines and save ......................
$!..............................................................................
$! VAX/VMS archive file created by VMS_SHAR V-5.01 01-Oct-1987
$! which was written by Michael Bednarek (U3369429@ucsvc.dn.mu.oz.au)
$! To unpack, simply save and execute (@) this file.
$!
$! This archive was created by NAGY
$! on Tuesday 2-FEB-1988 10:02:01.68
$!
$! It contains the following 1 file:
$! RENAME_DIRECTORY.FOR
$!==============================================================================
$ Set Symbol/Scope=(NoLocal,NoGlobal)
$ Version=F$GetSYI("VERSION") ! See what VMS version we have here:
$ If Version.ges."V4.4" then goto Version_OK
$ Write SYS$Output "Sorry, you are running VMS ",Version, -
", but this procedure requires V4.4 or higher."
$ Exit 44
$Version_OK: CR[0,8]=13
$ Pass_or_Failed="failed!,passed."
$ Goto Start
$Convert_File:
$ Read/Time_Out=0/Error=No_Error1/Prompt="creating ''File_is'" SYS$Command ddd
$No_Error1: Define/User_Mode SYS$Output NL:
$ Edit/TPU/NoSection/NoDisplay/Command=SYS$Input/Output='File_is' -
VMS_SHAR_DUMMY.DUMMY
f:=Get_Info(Command_Line,"File_Name");b:=Create_Buffer("",f);
o:=Get_Info(Command_Line,"Output_File");Set(Output_File,b,o);
Position(Beginning_of(b));Loop x:=Erase_Character(1);Loop ExitIf x<>"V";
Move_Vertical(1);x:=Erase_Character(1);Append_Line;
Move_Horizontal(-Current_Offset);EndLoop;Move_Vertical(1);
ExitIf Mark(None)=End_of(b) EndLoop;Position(Beginning_of(b));Loop
x:=Search("`",Forward,Exact);ExitIf x=0;Position(x);Erase_Character(1);
If Current_Character='`' then Move_Horizontal(1);else
Copy_Text(ASCII(INT(Erase_Character(3))));EndIf;EndLoop;Exit;
$ Delete VMS_SHAR_DUMMY.DUMMY;*
$ Checksum 'File_is
$ Success=F$Element(Check_Sum_is.eq.CHECKSUM$CHECKSUM,",",Pass_or_Failed)+CR
$ Read/Time_Out=0/Error=No_Error2/Prompt=" CHECKSUM ''Success'" SYS$Command ddd
$No_Error2: Return
$Start:
$ File_is="RENAME_DIRECTORY.FOR"
$ Check_Sum_is=473192705
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X subroutine rename_directory( code )
X
X include 'swing.cmn'
X include '($ssdef)'
X include '($smgdef)'
X
X character new_dir*42, key, string*39, message*255, file*255
X integer ikey, len_string, lib$rename_file, code, parent
X integer sys$getmsg, istat, len_message, ipos, from_level
X integer old_line, old_level, from_num, from_line, ii, jj
X logical dir_to_file, finished, check_directory_move
X
X if ( code .eq. 20 ) then
X
X call print_message( ' ', 0 )
X call smg$set_cursor_abs( window3, 1, 1 )
X call smg$read_string( keyboard, string,
X . 'Enter new name to give directory: ',
X . 39,,,,len_string,, window3 )
X
X new_dir = ' '
X jj = 0
X
X do ii = 1, len_string
X if (string(ii:ii) .ne. '[' .and. string(ii:ii) .ne. ']'.and.
X . string(ii:ii) .ne. '.' .and. string(ii:ii) .gt. ' ' .and.
X . string(ii:ii) .ne. ';' ) then
X jj = jj + 1
X new_dir(jj:jj) = string(ii:ii)
X end if
X end do
X
X call str$upcase( new_dir, new_dir )
X
X if ( jj .ne. 0 ) then
X if ( dir_to_file( node(node_num).spec,
X . node(node_num).length,
X . file, ipos ) ) then
X istat = lib$rename_file( file,
X . new_dir(1:jj)//'.DIR;1',,,
X . 1 )
X
X if ( istat .eq. ss$_normal ) then
X call file_to_dir( file(1:ipos)//new_dir(1:jj)//'.DIR',
X . node(node_num).spec,
X . node(node_num).length,
X . node(node_num).name )
X
X parent = 0
X call move_node( node_num, parent )
X
X call adjust_node_pointers
X
X call load_display
X
X cur_line = node(node_num).line
X cur_level = node(node_num).level
X
X call update_screen( cur_line, cur_level )
X
X call print_message( 'Subdirectory renamed', 0 )
X
X do_save = .true.
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 end if
X else
X call smg$erase_display( window3 )
X end if
X
X else if ( code .eq. 30 ) then
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$change_rendition( window2, from_line, from_level*17+1,
X . 1, 12, node(from_num).rend )
X
X call print_message( 'Travel to new parent directory and hit '//
X . 'RETURN - Hit 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( jj .ge. 1 .and. node_pointer(ii,jj) .eq. 0 )`009!LAW
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 if ( .not. check_directory_move( from_num, node_num ) ) then
X call update_screen( cur_line, cur_level )
X call print_message( 'Rename would cause too great a '//
X . 'directory depth', 0 )
X return
X end if
X
X if ( dir_to_file( node(from_num).spec,
X . node(from_num).length,
X . file, ipos ) ) then
X
X istat = lib$rename_file( file,
X . node(node_num).spec(1:node(node_num).length)//
X . '*.dir;1',,, 1 )
X
X if ( istat ) then
X call move_node( from_num, node_num )
X
X call adjust_node_pointers
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 print_message( 'Subdirectory has been moved', 0 )
X
X do_save = .true.
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 end if
X else
X call smg$erase_display( window3 )
X end if
X else
X call smg$erase_display( window3 )
X end if
X
X return
X end
$ GoSub Convert_File
$ Exit
-------