Program READTAR ! Version 1.0 July 1984 c c c***************************************************************************** c c This program will read and DEformat UNIX 'tar' tapes. c It is assumed that the TAR container file is blocked at c 10240 bytes/block. Any other format and this program will c have to be modified. c If file is on tape the mount command is: c $ Mount/foreign/block=10240 Mxyz: c c The name of the input file should be the Tapedrive for TAR c container files on tape. c c c implicit integer*4 (a-z) integer*4 tape_channel,max_bytes,max_pos character*80 command_line,file_to_get character*1024 buffer character*1 total_buffer(10240),answer character*1 readbuf(1024) character*50 unix_filename,file_name character*128 current_dir,unix_dir,vms_dir logical*1 last_file,skip_file,query_file,single_file,list_only logical*1 Log_on,file_list,Debug_On,dir_tree external tar_table equivalence (buffer,readbuf) common /buffers/total_buffer,position,Tape_Channel,max_bytes,Max_Pos call lib$get_foreign(command_line,,ilen) if(.not.(cli$dcl_parse('readtar '//command_line(:ilen),tar_table))) & call exit if (cli$present('LOG')) log_on = .true. if (cli$present('LIST')) then list_only = .true. log_on = .false. goto 50 end if if (cli$present('QUERY')) query_file = .true. if (cli$present('DEBUG')) debug_on = .true. if(cli$present('FILE')) then call cli$get_value('FILE',file_to_get) ilen_file = charlen(file_to_get) if(file_to_get(1:1).eq.'"') then file_to_get = file_to_get(2:) ilen_file = ilen_file - 1 end if if(file_to_get(ilen_file:ilen_file).eq.'"') then ilen_file = ilen_file - 1 file_to_get = file_to_get(:ilen_file) end if if(file_to_get(1:1).eq.'@') then if(debug_on) write(6,*) 'Files to get are from file "', 1 file_to_get(2:ilen_file),'"' file_list = .true. open(unit=10,file=file_to_get(2:ilen_file),readonly, 1 status='old',err=750) read(10,20,err=750,end=850) ilen_file,file_to_get 20 format(q,a) end if single_file = .true. if(debug_on) write(6,*) ' The next file to get is: ', 1 file_to_get(:ilen_file) end if 50 open(unit=1,name='tape:',form='unformatted',err=650, 1 type='old',readonly,recl=2560,recordtype='variable') rewind 1 200 call read_buffer (readbuf,1,512) last_file = .true. do i=1,512 if(ichar(readbuf(i)).ne.0) last_file = .false. end do if(last_file) then write(6,*) '%I, End of files on tape.' call exit end if last = 0 ifirst = 0 do 250 i=100,1,-1 if(last.eq.0.and.ichar(readbuf(i)).ne.0) last = i if(ifirst.eq.0.and.readbuf(i).eq.'/') ifirst=i+1 250 continue if(ifirst.eq.0) ifirst = 1 istatus = ots$cvt_to_l(buffer(125:135),isize) if(.not.istatus) isize = 0 if( (list_only).or.(debug_on) ) 1 write(6,*) buffer(:last), ' Size: ',isize unix_filename = buffer(ifirst:last) unix_dir = buffer(:ifirst-1) if(buffer(157:157).eq.'1') then write(6,*) 'Link. ',unix_filename go to 200 endif skip_file = .false. if(list_only) skip_file = .true. ilen_unix_file = charlen(unix_filename) if(ilen_unix_file.eq.0) skip_file = .true. if(single_file) then ! if( .not.(file_list) ) call str$upcase(unix_filename,unix_filename) if(unix_filename(:ilen_unix_file).eq.file_to_get(:ilen_file)) then if(file_list) then read(10,20,end=850,err=750) ilen_file,file_to_get if(debug_on) write(6,*) ' The next file to get is: ', 1 file_to_get(:ilen_file) end if dir_tree = .false. skip_file = .false. else if(file_to_get(:ilen_file).eq.buffer(:last)) then if(file_list) then read(10,20,end=850,err=750) ilen_file,file_to_get if(debug_on) write(6,*) ' The next file to get is: ', 1 file_to_get(:ilen_file) end if dir_tree = .true. skip_file = .false. else skip_file = .true. end if end if if(query_file) then write(6,260) Buffer(:last) 260 format(' ',a,' ? ',$) read(5,270,end=600) answer 270 format(a1) if((answer.ne.'Y').and.(answer.ne.'y')) skip_file = .true. end if if( .not.skip_file ) then c - - Compare the directories, get a new one if we must - - if(dir_tree.and.( current_dir(:len_cdir).ne.unix_dir(:ifirst-1)) ) then call vms_file(vms_dir, unix_dir, len_vdir, 'D') current_dir = unix_dir(:ifirst-1) len_cdir = ifirst - 1 call lib$create_dir(vms_dir(:len_vdir) ) if(log_on) write(6,*) ' Creating directory: ',vms_dir(:len_vdir) end if if(.not.dir_tree) len_vdir = 0 c -- Create a compatible VMS filename -- call vms_file( file_name, unix_filename, file_name_len,'F') 300 end if if(.not.skip_file) then if(log_on) write(6,*) 1 '"',unix_filename(:ilen_unix_file), 2 '" is being created as "',file_name(:file_name_len),'"' open(unit=2,name=vms_dir(:len_vdir)//file_name(:file_name_len), 1 defaultfile='_._', 2 type='new',carriagecontrol='list') end if istart = 0 if(isize.eq.0) then close(unit=2) go to 200 end if 350 call read_buffer(readbuf,istart+1,istart+512) istart = istart + min(512,isize) isize = isize - min(512,isize) if(skip_file) then istart = 0 if(isize.gt.0) go to 350 go to 200 endif 400 do 450 i=1,istart if(ichar(readbuf(i)).eq.10) go to 500 if(i.gt.132) then c must be bad file, lines too long skip_file = .true. write(6,*) '%E, Binary file, ',file_name(:file_name_len), 1 ', cannot copy.' close(unit=2,dispose='delete') if(isize.gt.0) go to 350 goto 200 endif 450 continue if(isize.gt.0) go to 350 500 write(2,550) buffer(1:i-1) 550 format(a) buffer=buffer(i+1:) istart = istart - i if(istart.gt.0) go to 400 if(isize.gt.0) go to 350 close(unit=2) go to 200 600 close(unit=1) call exit 650 write(6,*) '%F, Tape not assigned or mounted' write(6,*) '%I, The correct command is:' write(6,*) '%I, "$ Mount/foreign TAPE TAPE"' call exit 750 write(6,*) '%F, Cannot locate file list.' call exit 850 write(6,*) '%I, End of requested file listing.' call exit end c c------------------------------------------------------------ c This subroutine will attempt to convert a UNIX filename c to a compatible VMS filespec. c c c subroutine VMS_FILE(VMS_filename,UNIX_filename,j,code) logical*1 Found_dpoint integer j,charlen,last_char,last_dir character*(*) VMS_filename,UNIX_filename character*1 code c -- Create a compatible VMS filename -- j = 0 found_dpoint = .false. last_char = charlen(UNIX_filename) do i=1,last_char,1 i_char = ichar(UNIX_filename(i:i)) if(j.lt.75) then !keep under the limit if( (i_char.ge.48).and.(i_char.le.57) ) then ! 0-9 j = j + 1 VMS_filename(j:j) = UNIX_filename(i:i) else if( (i_char.ge.65).and.(i_char.le.90) ) then ! a-z j = j + 1 VMS_filename(j:j) = UNIX_filename(i:i) else if( (i_char.ge.97).and.(i_char.le.122) ) then ! A-Z j = j + 1 VMS_filename(j:j) = UNIX_filename(i:i) else if( (i_char.eq.36).or.(i_char.eq.95) ) then ! '_' or '$' j = j + 1 VMS_filename(j:j) = UNIX_filename(i:i) else if( i_char.eq.46 ) then ! The magic '.' j = j + 1 if(.not.(found_dpoint) ) VMS_filename(j:j) = '.' if( found_dpoint ) VMS_filename(j:j) = '_' found_dpoint = .true. c - - Check for a Directory separator (But at the start we fix later) else if( (code.eq.'D').and.(i_char.eq.47).and.(i.ne.1) ) then j = j + 1 VMS_filename(j:j) = '.' last_dir = j end if if(j.eq.38) then j = j + 1 VMS_filename(j:j) = '.' found_dpoint = .true. end if end if !if we go over we do nothing! end do if( (.not.(found_dpoint)).and.(code.eq.'F') ) then j = j + 1 VMS_Filename(j:j) = '.' end if c - - Now we fix up the whole directory spec! if(code.eq.'D') then VMS_Filename(last_dir:last_dir) = ']' VMS_Filename = '[.'//VMS_filename j = j + 2 end if return end c c-------------------------------------------------------- c subroutine read_buffer(the_buffer,start,finish) implicit integer*4 (a-z) integer*2 iosb(4) integer*4 max_bytes,max_pos,position,service_status,Tape_Channel character*1024 the_buffer character*1 total_buffer(10240) character*512 parts_of_buffer(20) include '($ssdef)' include '($iodef)' equivalence (parts_of_buffer,total_buffer) common /buffers/total_buffer,position,Tape_Channel,max_bytes,Max_Pos if( position.eq.0 ) then c - - Assign the tape channel - - Service_Status = Sys$Assign('TAPE:', Tape_Channel, , ) if( .not.(Service_Status) ) 1 call Lib$Stop( %val(Service_Status) ) c - - Rewind the tape to start at the beginning - - Service_Status = Sys$Qiow(, %Val(Tape_Channel), 1 %Val(Io$_Rewind), iosb, , , , , , , , ) if( .not.(Service_Status) ) 1 call Lib$Stop( %val(Service_Status) ) c - - Get the first block and setup max_pos and block Service_Status = Sys$Qiow(, %Val(Tape_Channel), 1 %Val(Io$_ReadlBlk), iosb, , , %ref(total_buffer), 2 %val(10240), , , , ) if( .not.(Service_Status) ) 1 call Lib$Stop( %val(Service_Status) ) position = 1 max_bytes = iosb(2) max_pos = max_bytes / 512 write(6,10) max_pos 10 format(' Tape blocksize: ',i3) else if(position.gt.max_pos) then c - - Read the next block Service_Status = Sys$Qiow(, %Val(Tape_Channel), %Val(Io$_ReadlBlk), 1 iosb, , , %ref(total_buffer), %val(Max_Bytes), , , , ) if( .not.(Service_Status) ) 1 call Lib$Stop( %val(Service_Status) ) position = 1 end if the_buffer(start:finish) = parts_of_buffer(position) position = position + 1 return end c c----------------------------------------------------------- c this function will return the actual length of the c string and not the length of the variable as returned by c the FORTRAN call "LEN" this will check for the last c ascii character that is not a " " or a "^@" integer*4 function charlen(string) implicit integer*4 (a-z) character*(*) string size = len(string) do location = size , 1 , -1 value = ichar(string(location:location)) if((value.ne.0).and.(value.ne.32)) goto 10 end do 10 charlen = location return end