!-------------------------------------------------------------- PROGRAM MODIFY ! Program to modify ASCII files. Files may be converted to fixed ! record length and/or detabbed, and a search string may be replaced by a ! replace string. The syntax is: ! ! $ MODIFY/qualifier File_spec Search_string Replace_string ! ! Note that string parameters are automatically converted to upper case ! by VMS unless they are enclosed in quotes. ! Wild cards are allowed in the file specification. ! ! Valid qualifiers are: ! ! /CONFIRM (Confirm each change) ! /NOLOG (Don't log each change to the screen) ! /CONTROL (Interpret characters preceded by ^ as control ! characters) ! /EXACT (Require an exact match of the search-string, ! including the case. The default is NOEXACT) ! /FIXED (Output file is to have fixed record length--requires ! LENGTH qualifier) ! /LENGTH=n (Record length of fixed length output file or maximum ! length of variable length file) ! /OUTPUT=fspec (Output file name specification. By default the output ! file has the same name as the input, with an ! incremented version number) ! /RANGE=n1:n2 (Search only columns n1 to n2 for the specified string) ! ! /DETAB=n (Convert tabs to spaces with a tab length of n. ! If n is not specified and detabbing is required, ! the DEC standard of n=8 will be used.) ! ! /WRAP (Word wrap lines longer than the allowed line length) ! ! /TRUNCATE (Truncate lines longer than the allowed line length) ! ! /CLIP[=c1:c2] (Clip text outside the allowed range. The range ! is specified by the range qualifier columns or ! characters specified by the clip qualifier) ! ! /EXCLUSIVE (Exclude the limits of clip range) ! ! /F77 (Require Fortran 77 formatting/detabbing) ! ! /COMMENT Convert comments to F77 standard form ! ! /UNCOMMENT Remove all comments and debug lines ! ! ! L2MAX is the maximum record length to write to file ! LSCR is the maximum record length to write to terminal ! ! There is an associated command definition file: ! MODIFY.CLD which is processed with the command ! $ SET COMMAND PNS_LIB:MODIFY ! ! Programmer: T.G. Worlton ! Version 2.0 28-JAN-1987 ! ! Modified to allow record lengths up to 512 bytes ! Modified to allow editing (Retyping) records up to 158 bytes TGW 11/27/91 ! Modified to add F77 qualifier to reformat Fortran files. TGW 12/4/91 C PARAMETER LDIN=512,LDOUT=550 INTEGER*4 STATUS,CONTEXT,OUTLEN,L2MAX,C1,C2 CHARACTER*30 CC,FM,ORG,RTYPE INTEGER*4 RCL INTEGER*2 LP1,LP2,LP3,LP4,LX CHARACTER CC1,CC2,CLIPB*10,CT1,CT2,DO*2,CTYPE*4,NEWLINE*2 CHARACTER CAPBUF*550,BUFF*512,BUFF2*550 CHARACTER*80 RESULT,RELATED,FNAME,OUTFILE,OUTSPEC,OUTTEMP CHARACTER*60 DIRSPEC,RFTEMP,FSEARCH CHARACTER*20 LENSTR,RANGE,TABSTR CHARACTER*80 FIN,STR1,STR2,STRA,STRB CHARACTER*132 BLANKS/' '/ EXTERNAL RMS$_NMF,RMS$_EOF,CLI$PRESENT,CLI$GET_VALUE EXTERNAL CLI$_DEFAULTED,CLI$_ABSENT,CLI$_NEGATED,CLI$_COMMA INTEGER*4 RMS$_NMF,RMS$_EOF,CLI$PRESENT,CLI$GET_VALUE INTEGER*4 FIDBLK(3)/3*0/ INTEGER CLI$_DEFAULTED,CLI$_ABSENT,CLI$_NEGATED,CLI$_COMMA LOGICAL *1 CONI,CONF,MOD,QUIT,ABORT,MEXACT,DONE,FLIST,F77MOD BYTE DOLL,BCC DATA DOLL/'$'/,IFPRESENT/261401/ NEWLINE(1:) = CHAR(13)//CHAR(10) CALL CLI$GET_VALUE('STRING1',STR1,LP2) LS1 = LP2 CALL CLI$GET_VALUE('STRING2',STR2,LP3) LS2 = LP3 CALL GTERM(LPAGE,LSCR,LFORM) ! Get screen width LSCRIN = LSCR ! Save initial screen width ! Check for the presence of optional qualifiers. NCONF = CLI$PRESENT('CONFIRM') M1 = CLI$PRESENT('CONFIRM') IF(CLI$PRESENT('EXACT') .EQ. IFPRESENT 1 .AND. CLI$PRESENT('EXACT') .NE. %LOC(CLI$_NEGATED) ) THEN MEXACT = .TRUE. ELSE MEXACT = .FALSE. END IF IF(.NOT. MEXACT) THEN CALL STR$UPCASE(STR1,STR1) END IF IF(CLI$PRESENT('OUTPUT') ) THEN CALL CLI$GET_VALUE('OUTPUT',OUTSPEC,LP4) OUTLEN = LP4 TYPE *,'Output file Spec is: ',OUTSPEC(1:OUTLEN) END IF IF(CLI$PRESENT('LENGTH') .OR. CLI$PRESENT('FIXED')) THEN CALL CLI$GET_VALUE('LENGTH',LENSTR,LX) READ(LENSTR(1:LX),20) L2MAX 20 FORMAT(I5) ELSE L2MAX = 550 END IF IF(L2MAX .GT. LSCR .AND. L2MAX .LE. 132) THEN LSCR = 132 CALL STERM(LPAGE,LSCR,LFORM) ! Set new screen width END IF IF(CLI$PRESENT('DETAB') ) THEN CALL CLI$GET_VALUE('DETAB',TABSTR,LDX) IF(LDX .GT. 0) THEN READ(TABSTR(1:LDX),20) LTAB ELSE LTAB=8 END IF ELSE LTAB=8 END IF IF(NCONF .EQ. IFPRESENT) THEN CONF = .TRUE. ELSE CONF = .FALSE. END IF IF(CLI$PRESENT('RANGE')) THEN STATUS=CLI$GET_VALUE('RANGE',RANGE,LX) ICOL = INDEX(RANGE(:LX),':') IF(ICOL .EQ. 0) THEN C1 = 1 READ(RANGE(1:LX),20) C2 ELSE READ(RANGE(1:ICOL-1),20) C1 READ(RANGE(ICOL+1:LX),20) C2 END IF TYPE *,'Modify columns',C1,' to',C2 ELSE C1 = 1 C2 = 550 END IF CC1 = CHAR(0) CC2 = CHAR(0) IF(CLI$PRESENT('CLIP')) THEN STATUS=CLI$GET_VALUE('CLIP',CLIPB,LX) ICOL = INDEX(CLIPB(:LX),':') IF(ICOL .EQ. 0 .AND. LX .GT. 0) THEN ! Clip on right only READ(CLIPB(1:LX),100) LC2,CC2 ELSE IF( LX .EQ. 1) THEN ! Clip after colon CC2 = ':' ELSE IF(ICOL .GT. 0) THEN ! Clip both sides READ(CLIPB(1:ICOL-1),100) LC1,CC1 READ(CLIPB(ICOL+1:LX),100) LC2,CC2 END IF TYPE *,'Clip text between characters "',CC1,'" and "',CC2,'"' ELSE END IF ! ! If control qualifier is present, ! translate ^S to CTRL_S, etc in str1 and str2 ! "^" is used to indicate that the following character ! is a control character. ! IF(CLI$PRESENT('CONTROL') ) THEN TYPE *,'Substituting for control characters' IS=1 DO WHILE (IS .LT. LS1) CT1 = STR1(IS:IS) IF(CT1 .EQ. '^') THEN IS = IS+1 CT2 = STR1(IS:IS) KS = ICHAR(CT2)-64 STR1(1:) = STR1(1:IS-2)//CHAR(KS)//STR1(IS+1:LS1) LS1 = LS1 - 1 ELSE IS = IS + 1 END IF END DO IS=1 DO WHILE (IS .LT. LS2) CT1 = STR2(IS:IS) IF(CT1 .EQ. '^') THEN IS = IS + 1 CT2 = STR2(IS:IS) KS = ICHAR(CT2)-64 STR2(1:) = STR2(1:IS-2)//CHAR(KS)//STR2(IS+1:LS2) LS2 = LS2 - 1 ELSE IS = IS + 1 END IF END DO END IF STATUS = LIB$GET_LUN(LUIN) STATUS = LIB$GET_LUN(LUOUT) ! Get FNAME from FIN string 1 STATUS=CLI$GET_VALUE('FSPEC',FNAME,LENF) IF (STATUS .EQ. %LOC(CLI$_COMMA) ) THEN FLIST=.TRUE. ELSE IF (STATUS) THEN FLIST=.FALSE. ELSE IF (STATUS .NE. %LOC(CLI$_ABSENT)) THEN CALL LIB$SIGNAL( %VAL(STATUS) ) CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT ELSE CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT END IF ABORT = .FALSE. ! Find actual file name (RESULT) from FNAME 10 STATUS = LIB$FIND_FILE(FNAME(1:LENF),RESULT,CONTEXT 1,,RELATED) IF(STATUS .EQ. %LOC(RMS$_NMF)) THEN CONTEXT=0 IF(FLIST) THEN GOTO 1 !Get another FNAME from the list ELSE CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT END IF END IF ! Found an Input File QUIT = .FALSE. RELATED = RESULT CALL STR$TRIM(RESULT,RESULT,LENR) ! Get output file name from RESULT IF(CLI$PRESENT('OUTPUT')) THEN CALL FONEW(RESULT,OUTSPEC,OUTFILE,OUTLEN) IF(OUTLEN .GT. 60) THEN TYPE *,'OUTLEN TOO LONG,',OUTLEN OUTLEN = 60 ELSE IF(OUTLEN .LT. 1) THEN TYPE *,'Invalid OUTLEN=',OUTLEN TYPE *,'OUTFILE=',OUTFILE(:60) CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT END IF ELSE OUTFILE(1:) = RESULT(1:) OUTLEN = LENR END IF ! Make output file temporary until end INAME = INDEX(OUTFILE(1:),']') + 1 ITYPE = INDEX(OUTFILE(INAME:),'.') + INAME - 1 OUTTEMP(1:) = OUTFILE(1:ITYPE)//'JOU' ! Change to version 0 (New Version) IVERS = INDEX(OUTFILE(1:),';') IF(IVERS .GT. 1) THEN NVERS=0 WRITE(OUTFILE(IVERS:),150) NVERS 150 FORMAT(';',I1) END IF ! Open the Input file FM = 'FORMATTED' OPEN(UNIT=LUIN,FILE=RESULT,STATUS='OLD',READONLY 1,ERR=1000) INQUIRE(UNIT=LUIN,CARRIAGECONTROL=CC,FORM=FM,ORGANIZATION=ORG, 1RECL=RCL,RECORDTYPE=RTYPE) IF(CLI$PRESENT('LENGTH') ) THEN RCL = L2MAX ELSE IF (CLI$PRESENT('F77')) THEN L2MAX = 72 ELSE L2MAX = RCL END IF IF(CLI$PRESENT('FIXED')) THEN RTYPE = 'FIXED' END IF D TYPE *,' CARRIAGECONTROL = ',CC D TYPE *,' FORM = ',FM D TYPE *,' ORGANIZATION = ',ORG D TYPE *,' RECORDTYPE = ',RTYPE D TYPE *,' RECL = ',RCL D TYPE *,' L2MAX = ',L2MAX TYPE *,'Working on file ',RESULT(1:LENR) ! Open the Journal file which will later be deleted or renamed ! Output file is: OUTFILE(1:) ! Journal file is: OUTTEMP(1:) IF(CC .EQ. 'UNKNOWN') CC = 'LIST' OPEN(UNIT=LUOUT,FILE=OUTTEMP,ERR=1100,STATUS='NEW', 1 FORM=FM,ORGANIZATION=ORG,RECL=RCL,RECORDTYPE=RTYPE, 2 CARRIAGECONTROL=CC,DEFAULTFILE=OUTTEMP,IOSTAT=IOS) NLINE = 0 !--- Main Loop for reading/modifying records. 2 BUFF(1:) = ' ' ! CLEAR INPUT BUFFER ! Read a record from the input file. READ(LUIN,100,END=200) NCH,BUFF 100 FORMAT(Q,A) d write(8,*) ' ' d write(8,*) buff(1:nch) BUFF2(1:) = BUFF(:NCH) NCH2 = NCH IF(QUIT) GOTO 3 ! Fix format for standard Fortran 77--no tabs. F77MOD = .FALSE. IF (CLI$PRESENT('F77')) THEN ITAB = INDEX(BUFF2(1:7),CHAR(9)) IF(ITAB .GT. 0) THEN F77MOD = .TRUE. IF(BUFF2(ITAB+1:ITAB+1) .GE. '1' .AND. 1 BUFF2(ITAB+1:ITAB+1) .LE. '9') THEN NBL = 6 - ITAB BUFF2(1:) = BUFF2(1:ITAB-1)//BLANKS(1:NBL)// 1 BUFF2( ITAB+1:ITAB+1)//BLANKS(1:1)// 2 BUFF2( ITAB+2:NCH2) ELSE NBL = 7 - ITAB BUFF2(1:) = BUFF2(1:ITAB-1)//BLANKS(1:NBL)// 1 BUFF2( ITAB+1:NCH2) END IF CALL STR_TRIM(BUFF2,BUFF2,NCH2) END IF IF(BUFF2(1:1) .EQ. '!' ) THEN IF (CLI$PRESENT('COMMENT')) THEN BUFF2(1:1) = '*' F77MOD = .TRUE. ELSE IF (CLI$PRESENT('UNCOMMENT')) THEN NLINE = NLINE + 1 GOTO 2 ! Delete line END IF ELSE IF(BUFF2(1:1) .EQ. 'D' .or. buff2(1:1) .eq. 'd' ) THEN IF (CLI$PRESENT('COMMENT')) THEN BUFF2(1:1) = 'C' F77MOD = .TRUE. ELSE IF (CLI$PRESENT('UNCOMMENT')) THEN NLINE = NLINE + 1 GOTO 2 END IF ELSE IF(BUFF2(1:1) .EQ. 'C' .OR. BUFF2(1:1) .EQ. '*' .or. 1 buff2(1:1) .eq. 'c') THEN IF (CLI$PRESENT('UNCOMMENT')) THEN NLINE = NLINE + 1 GOTO 2 END IF END IF END IF ! CONVERT TABS TO SPACES IF A RANGE OR MAXIMUM LENGTH IS GIVEN IF( CLI$PRESENT('RANGE') 1 .OR. CLI$PRESENT('LENGTH') 2 .OR. CLI$PRESENT('DETAB') 3 .OR. CLI$PRESENT('TRUNCATE') 4 .OR. CLI$PRESENT('CLIP') ) THEN CALL DETAB(BUFF2,LTAB,MTAB) IF(MTAB .EQ. 1) MOD = .TRUE. END IF ! Get length of detabbed record CALL STR_TRIM(BUFF2,BUFF2,NCH2) IF (CLI$PRESENT('F77') .AND. NCH2 .GT. 1) THEN ! Remove trailing comments if COMMENT or UNCOMMENT qualifiers present. IF(CLI$PRESENT('UNCOMMENT') .OR. CLI$PRESENT('COMMENT')) THEN ICOMNT = INDEX(BUFF2(2:NCH2),'!') + 1 IF(ICOMNT .GT. 1) THEN IF(ICOMNT .LT. NCH2) THEN BUFF2(ICOMNT:NCH2) = BLANKS(1:) NCH2 = ICOMNT - 1 CALL STR_TRIM(BUFF2,BUFF2,NCH2) END IF F77MOD = .TRUE. END IF END IF ! For F77 records, restrict length IF(NCH2 .GT. L2MAX) THEN BUFF2(L2MAX:NCH2) = BLANKS(1:NCH2-L2MAX+1) NCH2 = L2MAX CALL STR_TRIM(BUFF2,BUFF2,NCH2) F77MOD = .TRUE. END IF END IF D WRITE(8,*) BUFF2(1:NCH2) IF(.NOT. MEXACT) THEN CALL STR$UPCASE(CAPBUF,BUFF2) END IF ! Convert null records to blank record,length 1 IF(NCH2 .LE. 0) THEN NCH2 =1 BUFF2(1:1)=' ' END IF ! Get range to search (columns N1 to N2) IF(CC2 .EQ. CHAR(0)) THEN IF(NCH .GT. C2) THEN N2 = C2 ELSE N2 = NCH END IF IF(C1 .GT. 1 .AND. C1 .LT. N2) THEN N1 = C1 ELSE N1 = 1 END IF ELSE IF (CC1 .EQ. CHAR(0)) THEN N1 = 1 N2 =INDEX(BUFF2(1:),CC2(1:1)) IF(N2 .EQ. 0) N2 = NCH ELSE N1 = INDEX(BUFF2(1:),CC1(1:1)) N2 = INDEX(BUFF2(N1:),CC2(1:1)) + N1 - 1 END IF ! If search string found, MOD = .TRUE. IF(LS1 .GT. 0) THEN IF(.NOT. MEXACT) THEN JS1 = INDEX(CAPBUF(N1:N2),STR1(:LS1)) + N1 - 1 ELSE JS1 = INDEX(BUFF2(N1:N2),STR1(:LS1)) + N1 - 1 END IF IF(JS1 .LT. N1) THEN MOD = .FALSE. ELSE MOD = .TRUE. END IF ELSE MOD = .FALSE. END IF ! See if search string appears again in record DONE = .FALSE. DO WHILE (MOD .AND. .NOT. DONE) JS2 = JS1 + LS1 NCH2 = NCH2 + LS2 - LS1 IF(LS1 .GT. 0) THEN BUFF2(JS1:NCH2)=STR2(1:LS2)//BUFF2(JS2:) IF(.NOT. MEXACT) THEN CALL STR$UPCASE(CAPBUF,BUFF2) END IF END IF JS2 = JS1 + LS2 ! TGW 13-SEP-1988 IF(.NOT. MEXACT) THEN JS1 = INDEX(CAPBUF(JS2:NCH2),STR1(:LS1)) + JS2 - 1 ELSE JS1 = INDEX(BUFF2(JS2:NCH2),STR1(:LS1)) + JS2 - 1 END IF IF(JS1 .LT. JS2 .OR. JS1 .GT. N2) DONE = .TRUE. END DO IF(NCH2 .GT. L2MAX) THEN C NCH2 = L2MAX MOD = .TRUE. ELSE IF (CLI$PRESENT('FIXED') .OR. MTAB) THEN MOD = .TRUE. ELSE IF (CLI$PRESENT('CLIP') ) THEN MOD = .TRUE. END IF CONI = CONF IF (.NOT. MOD .AND. .NOT. F77MOD) GOTO 3 ! The current record is to be modified NLINE = NLINE + 1 IF(CONI) THEN ! Confirm proposed changes ! Display proposed changes IF(CLI$PRESENT('CLIP') .AND. CLI$PRESENT('RANGE')) THEN IR1 = N1 IR2 = N2 IF(CLI$PRESENT('EXCLUSIVE')) THEN IF(CC1(1:1) .NE. CHAR(0)) IR1 = IR1 + 1 IR2 = IR2 - 1 END IF IF(IR2 .GT. IR1) THEN IF(IR2 - IR1 + 1 .GT. LSCR) IR2 = IR1 + LSCR - 1 WRITE(6,105) BUFF(IR1:IR2) CALL REVIMG IR2 = N2 IF(IR2 - IR1 + 1 .GT. L2MAX) IR2 = IR1 + L2MAX - 1 WRITE(6,105,IOSTAT=IOS,ERR=190) BUFF2(IR1:IR2) CALL ATTOFF END IF ELSE IF(CLI$PRESENT('LENGTH') .AND. NCH2 .GT. L2MAX) THEN IF(CLI$PRESENT('TRUNCATE')) THEN IR2 = NCH IF(IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105) BUFF(1:IR2) CALL REVIMG IF(L2MAX .LT. LSCR) IR2 = LSCR WRITE(6,105,IOSTAT=IOS,ERR=190) BUFF2(1:IR2) CALL ATTOFF ELSE ! Display proposed changes with wrap ! Write unmodified record IR1 = 1 IF(NCH .GT. LSCR) THEN IR2 = IR1 + LSCR - 1 DO WHILE (IR1 .LT. NCH) IF(IR2 .GT. NCH) IR2 = NCH WRITE(6,105) BUFF(IR1:IR2) IR1 = IR2 + 1 IR2 = IR1 + LSCR - 1 END DO ELSE WRITE(6,105) BUFF(1:NCH) END IF ! Write modified record CALL REVIMG IR1 = 1 DO WHILE (IR1 .LE. NCH2) IR2 = NCH2 IF(IR2 - IR1 + 1 .GT. L2MAX) IR2 = IR1 + L2MAX - 1 WRITE(6,105) BUFF2(IR1:IR2) IR1 = IR2 + 1 END DO END IF CALL ATTOFF ELSE ! Confirm--No CLIP qualifier/No long record IR2 = NCH IF(IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105) BUFF(:IR2) CALL REVIMG IR2 = NCH2 IF(IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105,IOSTAT=IOS,ERR=190) BUFF2(:IR2) CALL ATTOFF END IF ! Prompt to accept change displayed. TYPE 120 ACCEPT 110,DO CALL STR$UPCASE(DO,DO) IF(DO .EQ. 'Q') THEN ! Quit making changes but finish file NCONF = %LOC(CLI$_ABSENT) TYPE *,'No more changes to ',OUTFILE(1:) NCH2 = NCH BUFF2(:NCH) = BUFF(:NCH) NLINE = NLINE - 1 QUIT = .TRUE. ELSE IF (DO .EQ. 'R') THEN ! Retype the string. IF(NCH2 .LT. 80) THEN ISTAT = GETSTRING(BUFF2,NCH2) ELSE NCHA = 79 STRA(1:) = BUFF2(1:79) ISTAT = GETSTRING(STRA,NCHA) STRB(1:) = BUFF2(80:NCH2) NCHB = NCH2 - 79 ISTAT = GETSTRING(STRB,NCHB) BUFF2(1:) = STRA(1:NCHA)//STRB(1:NCHB)//' ' NCH2 = NCHA + NCHB END IF ELSE IF (DO .EQ. 'A') THEN ! Abort and delete modified file. NLINE = 0 QUIT = .TRUE. ABORT = .TRUE. ELSE IF (DO .NE. 'Y') THEN ! NO--Undo the change NCH2 = NCH BUFF2(:NCH) = BUFF(:NCH) NLINE = NLINE - 1 END IF ! End confirm logic. ELSE IF(CLI$PRESENT('LOG') ) THEN IF(CLI$PRESENT('CLIP') ) THEN IR2 = NCH IF(IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105) BUFF(1:IR2) IR2 = N2 IR1 = N1 IF(CLI$PRESENT('EXCLUSIVE')) THEN IF(CC1(1:1) .NE. CHAR(0)) IR1 = IR1 + 1 IR2 = IR2 - 1 END IF IF(IR2 - IR1 + 1 .GT. LSCR) IR2 = LSCR + IR1 - 1 IF(IR2 .GT. IR1) THEN CALL REVIMG WRITE(6,105,IOSTAT=IOS,ERR=190) BUFF2(IR1:IR2) CALL ATTOFF END IF ELSE IF(CLI$PRESENT('LENGTH') .AND. NCH2 .GT. L2MAX) THEN IF(CLI$PRESENT('TRUNCATE')) THEN IR2 = L2MAX IF( IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105) BUFF(1:IR2) CALL REVIMG IR2 = L2MAX IF(IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105,IOSTAT=IOS,ERR=190) BUFF2(1:IR2) CALL ATTOFF ELSE ! Wrap/Log--record longer than L2MAX ! Write unmodified record IR1 = 1 IF(NCH .GT. LSCR) THEN IR2 = IR1 + LSCR - 1 DO WHILE (IR1 .LT. NCH) IF(IR2 .GT. NCH) IR2 = NCH WRITE(6,105) BUFF(IR1:IR2) IR1 = IR2 + 1 IR2 = IR1 + LSCR - 1 END DO ELSE WRITE(6,105) BUFF(1:NCH) END IF ! Write modified record CALL REVIMG IR1 = 1 DO WHILE (IR1 .LE. NCH2) IR2 = NCH2 IF(IR2 - IR1 + 1 .GT. L2MAX) IR2 = IR1 + L2MAX - 1 WRITE(6,105) BUFF2(IR1:IR2) IR1 = IR2 + 1 END DO END IF CALL ATTOFF ELSE ! Log--record shorter than L2MAX IR2 = NCH IF(IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105) BUFF(:IR2) CALL REVIMG IR2 = NCH2 IF( IR2 .GT. LSCR) IR2 = LSCR WRITE(6,105,IOSTAT=IOS,ERR=190) BUFF2(:IR2) CALL ATTOFF END IF END IF 105 FORMAT(1X,A) 110 FORMAT(A) 120 FORMAT('$Do you want to make this change?(Y/N/R/Q/A):') 3 CONTINUE ! Now write out (modified) record IF(CLI$PRESENT('CLIP')) THEN IF(CLI$PRESENT('EXCLUSIVE')) THEN IF(CC1(1:1) .NE. CHAR(0)) IR1 = N1 + 1 IR2 = N2 - 1 ELSE IR1 = N1 IR2 = N2 END IF WRITE(LUOUT,110) BUFF2(IR1:IR2) ! Write clipped record ELSE IF(CLI$PRESENT('TRUNCATE')) THEN WRITE(LUOUT,110) BUFF2(1:L2MAX) ! Write truncated record ELSE ! Write wrapped record IR1 = 1 DO WHILE (IR1 .LE. NCH2) IR2 = NCH2 IF(IR2 - IR1 + 1 .GT. L2MAX) IR2 = IR1 + L2MAX - 1 WRITE(LUOUT,110) BUFF2(IR1:IR2) IR1 = IR2 + 1 END DO END IF IF(.NOT. ABORT) goto 2 ! Get another record 200 close(unit=LUIN) !end of file read from input file IF(NLINE .GT. 0) THEN ! NLINE is number of lines changed CALL STR$TRIM(OUTFILE,OUTFILE,LO) TYPE *,NLINE,' Lines changed in ',OUTFILE(1:LO) close(unit=LUOUT,dispose='KEEP',err=1110) CALL STR$TRIM(OUTTEMP,OUTTEMP,LTEMP) CALL LIB$RENAME_FILE(OUTTEMP(:LTEMP),OUTFILE(:LO) ) ELSE ! Delete JOU file if there are no changes IF(.NOT. CONF .AND. LS1 .GT. 0) 1 TYPE *,'"',STR1(:LS1),'"',' not found.' TYPE *,'No changes made to ',RESULT(1:) CLOSE(UNIT=LUOUT,DISPOSE='DELETE',ERR=1110) END IF IF(.NOT. QUIT) GOTO 10 ! Get next file CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT 1000 TYPE *,'No such file: "',RESULT(1:LENR),'"' CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT 1100 TYPE *,'Couldn''t open output file:',OUTTEMP(1:) TYPE *,'Input file was ',result(1:) TYPE *, 1'Exceeding QUOTA for the parent directory UIC could cause this' CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original type *,'iostat=',ios TYPE *,'FM =',FM TYPE *,'ORG =',ORG TYPE *,'RECL =',RCL TYPE *,'RTYPE =',RTYPE TYPE *,'CC =',CC CALL EXIT 1110 TYPE *,'Couldn''t close file:',OUTFILE(1:) TYPE *,'If no changes were made, delete access is required.' CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT 190 CLOSE(UNIT=LUIN) CLOSE (UNIT=LUOUT) CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original CALL EXIT END !-------------------------------------------------------- SUBROUTINE FONEW(RESULT,OUTSPEC,OUTFILE,OUTLEN) INTEGER*4 OUTLEN CHARACTER*(*) RESULT,OUTSPEC,OUTFILE CHARACTER*39 NAMER,NAMES,NAMEO,TYPER,TYPES,TYPEO 1,VERR,VERS,VERF CALL STR$TRIM(OUTSPEC,OUTSPEC,LO) IDOT = INDEX(OUTSPEC,'.') N1 = INDEX(RESULT(1:),']')+1 N2 = INDEX(RESULT(N1:),'.') + N1-1 - 1 NAMER = RESULT(N1:N2) NT1 = N2 + 2 NT2 = INDEX(RESULT(NT1:),';') + NT1-1 - 1 TYPER = RESULT(NT1:NT2) NS1 = INDEX(OUTSPEC(1:),']') + 1 IF(NS1 .EQ. 1) NS1 = INDEX(OUTSPEC(1:),':') + 1 NTS1 = INDEX(OUTSPEC(1:),';') + 1 IF(NTS1 .EQ. 1) CALL STR$TRIM(OUTSPEC,OUTSPEC,NTS1) ! GET DIRECTORY FROM OUTSPEC IF IT EXISTS, OTHERWISE, GET IT ! FROM RESULT ! GET NAME FROM OUTSPEC UNLESS IT IS *, THEN GET IT FROM RESULT ! GET TYPE FROM OUTSPEC UNLESS IT IS *, THEN GET IT FROM RESULT IF (INDEX(OUTSPEC(1:),'*') .EQ. 0) THEN OUTLEN = LO OUTFILE(:LO) = OUTSPEC(:LO) RETURN END IF IF(OUTSPEC(IDOT-1:IDOT-1) .EQ. '*') THEN NAMEO(1:) = NAMER(1:) ELSE NAMEO(1:) = OUTSPEC(NS1:IDOT-1) END IF IF(OUTSPEC(IDOT+1:IDOT+1) .EQ. '*') THEN TYPEO(1:) = TYPER(1:) ELSE TYPEO(1:) = OUTSPEC(IDOT+1:NTS1) END IF CALL STR$TRIM(NAMEO,NAMEO,L1) CALL STR$TRIM(TYPEO,TYPEO,L2) IF(NS1 .LE. 1) THEN OUTFILE(1:)=RESULT(1:N1-1)//NAMEO(1:L1) 1 //'.'//TYPEO(1:L2) ELSE OUTFILE(1:)=OUTSPEC(1:NS1-1)//NAMEO(1:L1) 1 //'.'//TYPEO(1:L2) END IF CALL STR$TRIM(OUTFILE,OUTFILE,OUTLEN) CALL STERM(LPAGE,LSCRIN,LFORM) ! Reset screen width to original ! Output file name is OUTFILE(1:OUTLEN) RETURN END !--------------------------------------------------------------------------- subroutine gterm(page,screen,form) ! ! Subroutine to determine and change terminal characteristics ! ! ! PROGRAMMER: T. G. Worlton ! Argonne National Lab ! Version 1.0 3/21/84 ! implicit integer*4 (a-z) character local*2,chn_buf*64 byte chn_buf_byte(64),rest_byte(30),ddi_byte(4), 1 class,type,page_len integer*2 buf_size,unit_no,name_off, 1 vol_pro,err_cnt,label_off integer*2 loc_chan,iosb(4) equivalence (chn_buf,chn_buf_byte), 1 (chn_buf_byte,dev_char) equivalence (dev_dep_info,ddi_byte), 1 (ddi_byte(4),page_len) common /pribuf/ dev_char, 1 class,type,buf_size, 1 dev_dep_info, 1 unit_no,name_off, 1 pid, 1 uic, 1 vol_pro,err_cnt, 1 op_cnt, 1 label_off,rest_byte external io$_setmode, 1 tt$m _wrap,tt$m_ttsync,tt$m_mechtab, 1 tt$m_mechform data local/'TT'/ data ifg/0/ ! ! Assign channel number if(ifg .ne. 1) then status=sys$assign(local,loc_chan,,) if (.not.status) call lib$stop(%val(status)) ifg = 1 end if ! ! get terminal characteristics status=sys$getchn(%val(loc_chan),,chn_buf,,) if (.not.status) call lib$stop(%val(status)) page = page_len screen = buf_size iform = dev_dep_info .and. %loc(tt$m_mechform) if(iform .eq. 0) then form = .false. else form = .true. end if return entry sterm(page,screen,form) if(ifg .ne. 1) then status=sys$assign(local,loc_chan,,) if (.not.status) call lib$stop(%val(status)) status=sys$getchn(%val(loc_chan),,chn_buf,,) if (.not.status) call lib$stop(%val(status)) ifg = 1 end if page_len = page buf_size = screen if(form) then dev_dep_info = dev_dep_info 1 .or. %loc(tt$m_mechform) else dev_dep_info = dev_dep_info 1 .xor. %loc(tt$m_mechform) end if status = sys$qiow(,%val(loc_chan),io$_setmode,iosb,,, 1 class,,,,,) return end !------------------------------------------------------------------ ! Subroutine to convert tabs to spaces. If no tab length is ! given, It assumes a tab length of 8 (DEC standard) subroutine detab(record,lentab,mtab) character*(*) record character*1 ht,sp*10 data sp/' '/ data ht/9/ call str_trim(record,record,len) call getnarg(narg) ! lentab is an optional argument giving the tab length ! If not specified, the DEC standard of 8 is used if(narg .gt. 1) then ll = %loc(lentab) else ll = 0 end if if(ll .gt. 0) then lt = lentab if(lt.gt.10) stop 'tab length too long' else lt = 8 end if lold = len 1 itab = index(record(1:lold),ht) if(itab .eq. 0) then goto 10 else inew = lt*(itab/lt+1) + 1 ns = inew - itab lnew = lold + ns record(1:lnew) = record(1:itab-1)// 1 sp(1:ns)// 2 record(itab+1:lold) lold = lnew end if goto 1 10 continue ! mtab is an optional argument indicating whether a tab ! was removed from this record (mtab=1 if record changed) if(narg .gt. 2 ) then lm = %loc(mtab) else lm=0 end if if(lm .ne. 0) then if(lold .gt. len) then mtab=1 else mtab=0 end if end if return end