home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / netsrcs / vms.tar < prev    next >
Encoding:
Internet Message Format  |  1986-09-07  |  49.2 KB
  1. From ramin@rtgvax.UUCP Sat Sep  6 19:18:04 1986
  2. Path: beno!seismo!uwvax!husc6!panda!genrad!decvax!decwrl!amdcad!cae780!leadsv!rtgvax!ramin
  3. From: ramin@rtgvax.UUCP
  4. Newsgroups: net.decus
  5. Subject: Reading TAR from VMS
  6. Message-ID: <91@rtgvax.UUCP>
  7. Date: 6 Sep 86 23:18:04 GMT
  8. Organization: Erewhon Travel
  9. Lines: 1607
  10. Keywords: Summaries, *ACTUAL PROGRAMS* (yow!)
  11. Posted: Sat Sep  6 19:18:04 1986
  12.  
  13.  
  14. Well... my recent inquiry about TAR programs in VMS garnished me
  15. the following responses... The last two have actual programs
  16. that were enclosed and I have included them verbatim (though
  17. it seems they are closely related... but I thought I'd throw them
  18. both in anyway...) I also have another FORTRAN one here that someone at
  19. a sister company wrote. I haven't included it since I don't know
  20. if he wants it distributed...
  21.  
  22. I have not fully tested any of them. But since this machine is
  23. shortly due to go off the net I figured I should send it out
  24. before they pull the plug...(:-( Barring circumstances I should be
  25. back on the net via another system in about a month and I might
  26. fix up the programs to allow subdirectory creations, etc...)
  27.  
  28. Again, thanks to all who responded.
  29.  
  30. P.S. John Gilmore (hoptoad!gnu) has also offered a copy of a C TAR program
  31. he has... Hopefully I'll get it soon enough... If someone needs to
  32. try it out they could contact him directly if I'm not around...
  33.  
  34. ramin
  35.  
  36. ***************************************************************************
  37.  
  38. From: H}vard Eidnes <lll-lcc!caip!seismo!mcvax!vax.runit.unit.uninett!H_Eidnes>
  39.  
  40. I saw your recent request for some TAR program on VMS. It just
  41. happens that a friend of mine recently wrote such a program.
  42. The program is written in VMS Pascal. It has mainly been used
  43. to read TAR tapes down to TAR files on disk to be transferred
  44. to a Unix system to be unpacked. We've used Kermit to transfer
  45. from our VMS computer to a MicroVAX II (without 1/2" tape), and
  46. that has worked, but is slow, eg. it took 12hrs transferring
  47. TeX, but it worked...
  48.  
  49. The Pascal program is capable of just extracting a part of a tape
  50. by giving it a starting and ending filename prefix. It also has
  51. routines to do actual extraction on VMS, but we haven't used these
  52. routines much. NB: the program only handles TAR files blocked 20.
  53.  
  54. I will be happy to send you the program if you want it.
  55.  
  56. ***************************************************************************
  57.  
  58. From: lll-lcc!caip!uw-beaver!uw-june!gordon (Gordon Davisson)
  59.  
  60. Here's a program that does what you want.  It did get into a recent decus
  61. tape (VAX85C?), but that version happens to not work.  Use this instead.
  62.  
  63. -- 
  64. Human:    Gordon Davisson
  65. ARPA:     gordon@uw-june.ARPA
  66. UUCP:     {ihnp4,decvax,tektronix}!uw-beaver!uw-june!gordon
  67. Bitnet:   gordon@uwaphast
  68. ATT:      (206) 527-0832
  69. USnail:   5008 12th NE, Seattle, WA, 98105
  70.  
  71. --------------- cut here, then run the file (with an @) ---------------
  72. $!
  73. $ write sys$output "creating CVT.FOR"
  74. $ create CVT.FOR
  75. $ deck
  76. c
  77. c this subroutine converts a complete filespec (directory+file) name from
  78. c unix format to VMS
  79. c
  80.       subroutine cvt_dir_uv( unix, vms, vlen )
  81.  
  82.       parameter reserved = 10
  83.       character*(*) unix, vms
  84.       integer*2 vlen, i, j
  85.  
  86.       vms( 1:1 ) = '['
  87.       vlen = 1
  88.       i = 1
  89.       if ( unix( 1:1 ) .eq. '/' ) i = 2
  90.       j = index( unix( i: ), '/' )
  91.       do while ( j .ne. 0 )
  92.          vms( vlen+1:vlen+1 ) = '.'
  93.          call cvt_string_uv( unix( i : i+j-2 ), vms( vlen+2: ), k )
  94.          i = i + j
  95.          j = index( unix( i: ), '/' )
  96.          vlen = vlen + k + 1
  97.          if ( vlen + reserved .gt. len( vms )) then
  98.             vlen = len( vms ) - reserved
  99.             if ( vms( vlen:vlen ) .eq. '.' ) vlen = vlen - 1
  100.             do while ( j .ne. 0 )
  101.                i = i + j
  102.                j = index( unix( i: ), '/' )
  103.             end do
  104.          end if
  105.       end do
  106.  
  107.       if ( vlen .eq. 1 ) then
  108.          vlen = 0
  109.       else
  110.          vlen = vlen + 1
  111.          vms( vlen:vlen ) = ']'
  112.       end if
  113.  
  114.       call cvt_file_uv( unix( i: ), vms( vlen+1: ), k )
  115.       vlen = vlen + k
  116.       return
  117.  
  118.       end      
  119.  
  120. c
  121. c this subroutine converts an individual file name from unix format to VMS
  122. c
  123.       subroutine cvt_file_uv( unix, vms, vlen )
  124.  
  125.       parameter mlen1 = 64, mlen2 = 64
  126. c     parameter mlen1 = 9, mlen2 = 3       ! for version 3 and before
  127.       character*(*) unix, vms
  128.       integer*2 vlen, i, j
  129.  
  130.       i = index( unix, '.' )
  131.       if ( i .eq. 0 ) i = len( unix ) + 1
  132.  
  133.       call cvt_string_uv( unix( :i-1 ), vms, j )
  134.       if ( j .gt. mlen1 ) j = mlen1
  135.       vlen = j + 1
  136.       if ( vlen .gt. len( vms )) vlen = len( vms )
  137.       vms( vlen:vlen ) = '.'
  138.  
  139.       if ( i .ge. len( unix )) return
  140.  
  141.       call cvt_string_uv( unix( i+1: ), vms( vlen+1: ), j )
  142.       if ( j .gt. mlen2 ) j = mlen2
  143.       vlen = vlen + j
  144.       return
  145.  
  146.       end
  147.  
  148. c
  149. c this subroutine converts a string to characters that can appear in
  150. c VMS filenames
  151. c
  152. c if you're using a version 3 or pervious VMS system, you'll have to
  153. c rewrite this to avoid _ and $.
  154. c
  155.       subroutine cvt_string_uv( unix, vms, vlen )
  156.  
  157.       character*(*) unix, vms, c*1
  158.       integer*2 vlen, i
  159.  
  160.       vms = unix
  161.       vlen = min( len( unix ), len( vms ))
  162.       do i = 1, vlen
  163.          c = vms( i:i )
  164.          if ( 'A' .le. c .and. c .le. 'Z' .or.
  165.      -        '0' .le. c .and. c .le. '9' .or.
  166.      -        c .eq. '_' .or. c .eq. '$'  ) then
  167.             continue
  168.          else if ( 'a' .le. c .and. c .le. 'z' ) then
  169.             vms( i:i ) = char( ichar( c ) - 32 )
  170.          else if ( c .eq. '-' ) then
  171.             vms( i:i ) = '_'
  172.          else
  173.             vms( i:i ) = '$'
  174.          end if
  175.       end do
  176.  
  177.       return
  178.  
  179.       end
  180.  
  181. c
  182. c this souroutine converts an octal digit to a 3-character protection mask
  183. c
  184.       subroutine cvt_prot( c, out )
  185.  
  186.       character c*1, out*3, mask( 8 )*3
  187.       data mask / '---', '--x', '-w-', '-wx',
  188.      -            'r--', 'r-x', 'rw-', 'rwx' /
  189.  
  190.       out = mask( ichar( c ) - ichar( '0' ) + 1 )
  191.       return
  192.  
  193.       end
  194.  
  195. $ eod
  196. $!
  197. $ write sys$output "creating TAPEIO.DCK"
  198. $ create TAPEIO.DCK
  199. $ deck
  200. c
  201. c parameters:
  202. c   blocklen is the size of the units tar works with
  203. c   saveblocks is the number of blocks into the file saved for a second chance
  204. c   maxrecl is the maximum length of record a text can have
  205. c   maxblockfactor is the maximum blocking factor this program can deal with
  206. c
  207.       parameter blocklen = 512, saveblocks = 5, maxrecl = 512,
  208.      -    maxblockfactor = 20
  209.  
  210. c secondary parameters calculated from those above
  211.       parameter recblocks = 2 + maxrecl/blocklen,
  212.      -   maxblocks = maxblockfactor + saveblocks + recblocks,
  213.      -   maxlen = blocklen*maxblocks
  214.  
  215. c these are numbers for fortran units to be used for various files
  216.       parameter inunit = 1, outunit = 2, listunit = 3, nameunit = 4
  217.  
  218. c
  219. c variables:
  220. c
  221. c i/o control stuff
  222.       integer*2 channel
  223.       logical*1 tape_file
  224.  
  225. c this is the buffer records get read into
  226.       character buffer*( maxlen ), block( maxblocks )*( blocklen )
  227.       equivalence ( buffer, block )
  228.  
  229. c control info for the buffer
  230.       integer*2 using, using2, curr
  231.       logical*1 eof
  232.  
  233.  
  234.       common /commonbuf/ buffer
  235.       common /commonints/ using, using2, curr, eof, tape_file, channel
  236. $ eod
  237. $!
  238. $ write sys$output "creating TAPEIO.FOR"
  239. $ create TAPEIO.FOR
  240. $ deck
  241. c
  242. c this routine accesses, checks, and rewinds the specified tape (or file,
  243. c if tape_file is true.
  244. c
  245.       subroutine open_tape( name )
  246.  
  247.       include 'tapeio.dck/list'
  248.       include '($iodef)/nolist'
  249.       include '($dvidef)/nolist'
  250.       include '($devdef)/nolist'
  251.       character*(*) name
  252.  
  253.       integer*2 iosb( 2 ), devreq_w( 2 )
  254.       integer*4 stat, devreq( 4 ), devchar, sys$assign, sys$qiow,
  255.      -    sys$getdvi
  256.  
  257.       equivalence ( devreq, devreq_w )
  258.       data devreq_w, devreq( 3 ), devreq( 4 )
  259.      -    / 4, dvi$_devchar, 0, 0 /
  260.  
  261.       if ( tape_file ) then
  262.          stat = sys$assign( name, channel,, )
  263.          if ( .not. stat ) goto 900
  264.          devreq( 2 ) = %loc( devchar )
  265.          stat = sys$getdvi( , %val( channel ),, devreq, iosb,,, )
  266.          if ( .not. stat ) goto 900
  267.          stat = iosb( 1 )
  268.          if ( .not. stat ) goto 900
  269.          if ( .not. btest( devchar, dev$v_avl )) goto 910
  270.          if ( .not. btest( devchar, dev$v_for )) goto 920
  271.          stat = sys$qiow( , %val( channel ), %val( io$_rewind ),
  272.      -       iosb,,,,,,,, )
  273.          if ( .not. stat ) goto 930
  274.          stat = iosb( 1 )
  275.          if ( .not. stat ) goto 930
  276.       else
  277.          open( inunit, err=950, name=name,
  278.      -       type='old', readonly )
  279.       end if
  280.  
  281.       return
  282.  
  283. c
  284. c fatal errors
  285. c
  286.   900 type *, 'Error accessing tape, ', name
  287.       call exit( stat )
  288.   910 type *, 'Tape offline or not available.'
  289.       call exit
  290.   920 type *, 'Tape must be mounted /foreign.'
  291.       call exit
  292.   930 type *, 'Error rewinding tape.'
  293.       call exit( stat )
  294.  
  295.   950 type *, 'Error opening input file, ', name
  296.       call exit
  297.  
  298.       end
  299.  
  300. c
  301. c this routine makes sure the next block is available, reading it from
  302. c tape if necessary.
  303. c
  304.       subroutine next_block
  305.       include 'tapeio.dck'
  306.       include '($iodef)/nolist'
  307.       integer*2 blen, u, i, iosb( 4 )
  308.       integer*4 stat, sys$qiow
  309.       data curr, blen / 0, 0 /
  310.  
  311.       eof = .false.
  312.       curr = curr + 1
  313.       if ( curr .le. blen / blocklen ) return
  314.  
  315.       if ( using2 .le. 0 ) then
  316.          u = using
  317.       else if ( using .le. 0 ) then
  318.          u = using2
  319.       else
  320.          u = min( using, using2 )
  321.       end if
  322.  
  323.       if ( u .gt. blen / blocklen ) then
  324.          type *, 'Internal error.  Call the debugger.'
  325.          call exit
  326.       else if ( u .gt. 1 ) then
  327.          buffer( 1 : blen - blocklen*(u-1)) =
  328.      -       buffer( 1+blocklen*(u-1) : blen )
  329.          blen = blen - blocklen*(u-1)
  330.          curr = curr - u + 1
  331.          using = using - u + 1
  332.          using2 = using2 - u + 1
  333.       else if ( u .lt. 1 ) then
  334.          blen = 0
  335.          curr = 1
  336.       end if
  337.  
  338.       do while ( curr .gt. blen / blocklen )
  339.          if ( tape_file ) then
  340.             stat = sys$qiow( , %val( channel ), %val( io$_readlblk ),
  341.      -          iosb,,, %ref( buffer( blen+1: )), %val( maxlen-blen )
  342.      -          ,,,, )
  343.             if ( .not. stat ) then
  344.                type *, 'Error reading from tape'
  345.                call exit( stat )
  346.             else if ( .not. iosb( 1 )) then
  347.                type *, 'Error reading from tape'
  348.                call exit( iosb( 1 ))
  349.             else if ( iosb( 2 ) .eq. 0 ) then
  350.                goto 99
  351.             endif
  352.             blen = blen + iosb( 2 )
  353.          else
  354.             read( inunit, 10, end=99 ) i, buffer( blen+1: )
  355.    10       format( q, a )
  356.             blen = blen + i
  357.          end if
  358.          if ( blen .gt. maxlen ) then
  359.             type *, 'Blocking factor too large.'
  360.             call exit
  361.          end if
  362.       end do
  363.       return
  364.  
  365. 99    curr = curr - 1
  366.       eof = .true.
  367.       return
  368.       end
  369. $ eod
  370. $!
  371. $ write sys$output "creating TAR.CLD"
  372. $ create TAR.CLD
  373. $ deck
  374. !**************************************TAR**************************************
  375. define verb TAR
  376.    image drc0:[gordon.decus.tar]TAR
  377.    parameter P1 , label=TAPE , prompt="Tape drive"
  378.       value (required,type=$infile)
  379.    qualifier FILE
  380.    qualifier EXTRACT
  381.    qualifier BINARY
  382.    qualifier INQUIRE
  383.    qualifier SECOND_CHANCE
  384.       default
  385.    qualifier NAMES
  386.       value (default="sys$output:",type=$outfile)
  387.    qualifier LIST
  388.       value (default="sys$output:",type=$outfile)
  389.    qualifier VERBOSE
  390.    qualifier FLATTEN
  391.       default
  392. $ eod
  393. $!
  394. $ write sys$output "creating TAR.FOR"
  395. $ create TAR.FOR
  396. $ deck
  397. c
  398. c This is tar for VMS, by Gordon Davisson (gordon@uw-june).  It is
  399. c not based on any liscenced software, and is completely in the
  400. c public domain.
  401. c
  402. c Version 1.0, Gordon Davisson, July 24 1985
  403. c revised by G.D. July 29 1985 to use io$_rewind right and not abuse rms$_eof
  404. c revised by G.D. Oct 17 1985 to make sure tape is mounted
  405. c
  406.       program tar
  407.  
  408.       parameter bell = char( 7 ), lf = char( 10 )
  409.       external cli$_present, cli$_negated, cli$_locpres, cli$_locneg,
  410.      -    cli$_absent, cli$_defaulted, cli$_normal,
  411.      -    cli$_comma, cli$_concat
  412.       include 'tapeio.dck/list'
  413.       character fname*100, out*128, pstr*9, prot*3, link*1, tmp*1
  414.       integer*2 i, j, start, finish, flen, olen, files,
  415.      -    stuff1, stuff2, stuff3, iosb( 2 )
  416.       integer*4 size, blocks, time, stat,
  417.      -    cli$get_value, cli$present, sys$assign, sys$qiow
  418.       logical*1 listing, naming, extracting, binary, inquiring,
  419.      -    verbose, second_chance, flatten, absent
  420.  
  421.       absent( stat ) = ( stat .eq. %loc( cli$_absent ) .or.
  422.      -                   stat .eq. %loc( cli$_negated ))
  423. c
  424. c parse command line
  425. c
  426. c file -- read from normal file, not a tape
  427.       stat = cli$present( 'file' )
  428.       if ( absent( stat )) then
  429.          tape_file = .true.
  430.       else if ( .not. stat ) then
  431.          goto 900
  432.       else
  433.         tape_file = .false.
  434.       end if
  435.  
  436. c p1 -- tape drive name
  437.       stat = cli$get_value( 'tape', fname, flen )
  438.       if ( .not. stat ) goto 900
  439.       call open_tape( fname( :flen ))
  440.  
  441. c p2 -- files to extract/list/whatever.  NOT IMPLEMENTED
  442. c     files = 0
  443. c     stat = cli$get_value( 'match', fname, flen )
  444. c     do while ( .not. absent( stat ))
  445. c        if ( .not. stat ) goto 900
  446. c        type *, 'File selector: ', fname( :flen )
  447. c        files = files + 1
  448. c        stat = cli$get_value( 'match', fname, flen )
  449. c     end do
  450.  
  451. c extract -- copy files to disk
  452.       stat = cli$present( 'extract' )
  453.       if ( absent( stat )) then
  454.          extracting = .false.
  455.       else if ( .not. stat ) then
  456.          goto 900
  457.       else
  458.         extracting = .true.
  459.       end if
  460.  
  461. c binary -- copy to disk in block mode
  462.       stat = cli$present( 'binary' )
  463.       if ( absent( stat )) then
  464.          binary = .false.
  465.       else if ( .not. stat ) then
  466.          goto 900
  467.       else
  468.         binary = .true.
  469.       end if
  470.  
  471. c inquire -- ask what to do to each file
  472.       stat = cli$present( 'inquire' )
  473.       if ( absent( stat )) then
  474.          inquiring = .false.
  475.       else if ( .not. stat ) then
  476.          goto 900
  477.       else
  478.         inquiring = .true.
  479.       end if
  480.  
  481. c second_chance -- try to recognize binary files and save them as such
  482.       stat = cli$present( 'second_chance' )
  483.       if ( absent( stat )) then
  484.          second_chance = .false.
  485.       else if ( .not. stat ) then
  486.          goto 900
  487.       else
  488.         second_chance = .true.
  489.       end if
  490.  
  491. c list -- list files on tape
  492.       stat = cli$get_value( 'list', fname, flen )     
  493.       if ( absent( stat )) then
  494.          listing = .false.
  495.       else if ( .not. stat ) then
  496.          goto 900
  497.       else
  498.          open( listunit, err=920, name=fname( :flen ), type='new',
  499.      -       defaultfile='tar.lis', carriagecontrol='list' )
  500.          listing = .true.
  501.       end if
  502.  
  503. c verbose -- make a verbose list
  504.       stat = cli$present( 'verbose' )
  505.       if ( absent( stat )) then
  506.          verbose = .false.
  507.       else if ( .not. stat ) then
  508.          goto 900
  509.       else
  510.         verbose = .true.
  511.       end if
  512.  
  513. c flatten -- extract all files to the current directory
  514.       stat = cli$present( 'flatten' )
  515.       if ( absent( stat )) then
  516.          flatten = .false.
  517.       else if ( .not. stat ) then
  518.          goto 900
  519.       else
  520.         flatten = .true.
  521.       end if
  522.  
  523. c names -- make a list of what unix filenames mapped to what VMS filenames
  524.       stat = cli$get_value( 'names', fname, flen )     
  525.       if ( absent( stat )) then
  526.          naming = .false.
  527.       else if ( .not. stat ) then
  528.          goto 900
  529.       else
  530.          open( nameunit, err=930, name=fname( :flen ), type='new',
  531.      -       defaultfile='tar.nam', carriagecontrol='list' )
  532.          naming = .true.
  533.       end if
  534.  
  535. c
  536. c file loop: executed for each file in the archive
  537. c
  538.       do while ( .true. )
  539.    10    using = 0
  540.          using2 = 0
  541.          call next_block
  542.          if ( eof .or. block( curr ) (1:1) .eq. char( 0 )) goto 899
  543.  
  544. c start parsing out a file entry -- parse the header
  545.          read( block( curr ), 1001 ) fname, prot, stuff1, stuff2,
  546.      -      size, time, stuff3, link
  547.  1001    format( a100, 3x, a3, 2x, 2(o6,2x), 2(o11,1x), o6, 2x, a1 )
  548.          blocks = ( size + blocklen - 1 ) / blocklen
  549.          flen = index( fname, char( 0 )) - 1
  550.          if ( flen .lt. 0 ) flen = len( fname )
  551.  
  552. c add it to the list
  553.          if ( listing .and. verbose ) then
  554.             call cvt_prot( prot( 1:1 ), pstr( 1:3 ))
  555.             call cvt_prot( prot( 2:2 ), pstr( 4:6 ))
  556.             call cvt_prot( prot( 3:3 ), pstr( 7:9 ))
  557.             write( listunit, 2001 ) pstr, stuff1, stuff2, size,
  558.      -          time, fname( :flen )
  559.  2001       format( a9, i3, '/', i3, i7, i11, 1x, a )
  560.          else if ( listing ) then
  561.             write( listunit, 2002 ) fname( :flen )
  562.  2002       format( a )
  563.          end if
  564.  
  565. c ignore links
  566.          if ( link .eq. '1' ) goto 10
  567.  
  568. c skip if not extracting
  569.          if ( .not. extracting ) goto 40
  570.  
  571. c figure out what to do with the file
  572.          if ( inquiring ) then
  573.             call lib$get_input( tmp, fname( :flen ) // ': [ynbtq]' )
  574.             do while ( index( ' yYnNbBtTqQ', tmp ) .eq. 0 )
  575.                call lib$get_input( tmp,
  576.      -             bell // fname( :flen ) // ': [ynbtq]' )
  577.             end do
  578.             call str$upcase( tmp, tmp )
  579.             if ( tmp .eq. 'Q' ) goto 899
  580.          else
  581.             tmp = 'Y'
  582.          end if
  583.  
  584.          if ( tmp .eq. 'Y' .or. tmp .eq. ' ' ) then
  585.             tmp = 'T'
  586.             if ( binary ) tmp = 'B'
  587.          else if ( tmp .eq. 'N' ) then
  588.             goto 40
  589.          end if
  590.  
  591. c parse file name
  592.          call cvt_dir_uv( fname( :flen ), out, olen )
  593.          if ( flatten ) then
  594.             i = index( out( :olen ), ']' )
  595.             out = out( i+1:olen )
  596.             olen = olen - i
  597.          end if
  598.          if ( tmp .eq. 'B' ) goto 30
  599.  
  600. c create a text file
  601.    20    open( outunit, name=out( :olen ), type='new', recl=maxrecl,
  602.      -       defaultfile='.', carriagecontrol='list', err=38 )
  603.          if ( size .le. 0 ) then
  604.             close( outunit )
  605.             goto 99
  606.          end if
  607.  
  608. c copy the file to disk
  609.          if ( second_chance ) using2 = curr
  610.          call next_block
  611.          blocks = blocks - 1
  612.          start = 1
  613.          do while ( size .gt. 0 )
  614.             using = curr
  615.             finish = index( block( curr ) ( start: ), lf )
  616.             do while ( finish .eq. 0 .and. blocks .gt. 0 .and.
  617.      -          curr - using + 1 .lt. recblocks )
  618.                call next_block
  619.                blocks = blocks - 1
  620.                if ( eof ) goto 990
  621.                finish = index( block( curr ), lf )
  622.             end do
  623.             if ( finish .eq. 0 ) finish = 2 * blocklen + 1
  624.             if ( using .eq. curr ) finish = finish + start - 1
  625.             i = start + blocklen * (using-1)
  626.             j = finish + blocklen * (curr-1)
  627.             start = finish + 1
  628.             size = size - j + i - 1
  629.             if ( size .lt. 0 ) then
  630.                j = j + size
  631.                size = 0
  632.             end if
  633.             if ( using2 .ne. 0 .and. j - i .gt. maxrecl ) then
  634.                type *, 'Giving ', fname( :flen ), ' a second chance...'
  635.                blocks = blocks + curr - using2
  636.                curr = using2
  637.                using = 0
  638.                using2 = 0
  639.                close( outunit, dispose='delete' )
  640.                goto 30
  641.             end if
  642.             write( outunit, 2005, err=39, iostat=stat )
  643.      -          buffer( i : j-1 )
  644. 2005        format( a )
  645.             if ( curr - using2 .ge. saveblocks ) using2 = 0
  646.          end do
  647.  
  648.          close( outunit )
  649.          goto 99
  650.  
  651. c create a binary file
  652.    30    using = 0
  653.          using2 = 0
  654.          open( outunit, name=out( :olen ), type='new',
  655.      -       recl=blocklen, recordtype='fixed', defaultfile='.',
  656.      -       carriagecontrol='none', err=39 )
  657.  
  658.          do while ( blocks .gt. 0 )
  659.             call next_block
  660.             blocks = blocks - 1
  661.             write( outunit, 3001, err=39, iostat=stat ) block( curr )
  662.  3001       format( a )
  663.          end do
  664.          close( outunit )
  665.          goto 99
  666.  
  667. c got an error creating the file: skip it.
  668.    38    type *, 'Error creating ', out( :olen ), ' skipping...'
  669.          goto 40
  670.  
  671. c got an error writing the file: skip the rest of it.
  672.    39    type *, 'Error writing ', out( :olen ), ' skipping...'
  673.          close( outunit, dispose='delete' )
  674.  
  675. c skip the file
  676.    40    using = 0
  677.          using2 = 0
  678.          do i = 1, blocks
  679.             call next_block
  680.             if ( eof ) goto 990
  681.          end do
  682.          goto 10
  683.  
  684. c successfully copied file to disk: enter it in the names file
  685.    99    if ( naming ) write( nameunit, 2000 ) out( :olen ),
  686.      -       fname( :flen )
  687.  2000    format( a, ' -> ', a )
  688.  
  689.       end do
  690.  
  691. c end of tape: close it and exit!
  692.   899 close( inunit )
  693.       call exit
  694.  
  695. c
  696. c fatal errors
  697. c
  698.   900 type *, 'Error parsing command line'
  699.       call exit
  700.  
  701.   920 type *, 'Error opening listing file, ', fname( :flen )
  702.       call exit
  703.  
  704.   930 type *, 'Error opening names file, ', fname( :flen )
  705.       call exit
  706.  
  707.   990 type *, 'Premature end of tape while reading ', fname( :flen )
  708.       call exit
  709.  
  710.       end
  711. $ eod
  712. $!
  713. $ write sys$output "creating TAR.HLP"
  714. $ create TAR.HLP
  715. $ deck
  716. 1 TAR
  717.   Invokes the tape archive reader to read unix-format tapes.
  718.  
  719.   Format:
  720.  
  721.     TAR tape-name[:]
  722. 2 Parameter
  723.  
  724.  tape-name[:]
  725.  
  726.   Specifies the device name of the tape drive the archive is mounted on.
  727.   The archive must be mounted foreign.
  728.  
  729.   If the /FILE qualifier is specified, this parameter is interpreted as
  730.   the file name for the archive.
  731. 2 Command_Qualifiers
  732.  
  733. /BINARY
  734.  
  735.   Specifies that the files extracted should be put into fixed-length-512-
  736.   byte-record files and that no interpretation should be preformed on
  737.   the contents.
  738.  
  739. /EXTRACT
  740.  
  741.   Specifies that the files in the archive should be copied into the
  742.   directory, or subdirectories (depending on the /FLATTEN qualifier).
  743.  
  744. /FILE
  745.  
  746.   Specifies that, instead of a tape, the archive is contained in a normal
  747.   file.
  748.  
  749. /FLATTEN (D)
  750.  
  751.   Specifies that files extracted from the archive should be put in the
  752.   default directory even when the files would normally be put in
  753.   subdirectories.
  754.  
  755.   This qualifier is on by default because the program is incapable of
  756.   creating subdirectories to put the extracted files in, so unless they
  757.   exist already, /NOFLATTEN in a pure loss.
  758.  
  759. /INQUIRE
  760.  
  761.   Tells the program to ask the user what to do with each file it has been
  762.   told to extract.  The program prompts with the filename followed by a
  763.   list of options.  The options are:
  764.  
  765.      y - extract the file normally
  766.      n - skip the file
  767.      t - extract the file in text (not binary) mode
  768.      b - extract the file in binary mode
  769.      q - exit the program
  770.  
  771.   The y option is equivalent t or b depending on whether the /BINARY
  772.   qualifier was given.
  773.  
  774. /LIST
  775.  
  776.  /LIST=filename (default = sys$output:)
  777.  
  778.   Tells the program to create a list of all of the files on the tape.
  779.   If the /VERBOSE qualifier is also specified, the list contains more
  780.   than just the file names.
  781.  
  782. /NAMES
  783.  
  784.  /NAMES=filename (default = sys$output:)
  785.  
  786.   If files are extracted, the program creates a file giving the names
  787.   of the files on the tape and the VMS filenames they were mapped into
  788.   when extracted.
  789.  
  790. /SECOND_CHANCE (D)
  791.  
  792.   This specifies that if a file is being extracted in text mode, and
  793.   a line longer then 512 bytes in encountered sufficiently near the
  794.   beginning of the file, it should be re-extracted in binary mode.
  795.  
  796.   If negated, files with long lines are discarded in text mode.
  797.  
  798. /VERBOSE
  799.  
  800.   This specifies that lists should contain more information than just
  801.   the filename.
  802.  
  803. 2 Bugs
  804.   Here's a list of some of the more noticable bugs and deficiencies:
  805.      - It can't write tar tapes.
  806.      - It can't operate on only some of the files on a tape.
  807.      - Verbose listings contain the date in seconds since 1970 or so,
  808.          rather than any reasonable format.
  809.      - It can't create subdirectories to put files in. (that's why
  810.          /FLATTEN is the default)
  811.      - Error recovery and reporting could use improvement.
  812.      - probably others I can't think of at the moment.
  813.  
  814.   If you discover more bugs, fix them, or just have suggestions, mail
  815.   them to Gordon Davisson ({ihnp4|decvax}!uw-beaver!uw-june!gordon,
  816.   gordon@uw-june.ARPA, or gordon@uwaphast.BITNET).
  817. $ eod
  818.  
  819. ***************************************************************************
  820.  
  821. From: lll-lcc!ucdavis!vega!ccrdave (Lord Kahless)
  822.  
  823. I received this program from somebody, who received this program
  824. from somebody.  I don't know if it works because I've been to busy
  825. to test it.  Just substitute out the X@X@'s and go for it. Tell
  826. me how it works...
  827. X@X@From:    ALCOR::CCRDAN       "DAN GOLD" 11-AUG-1986 10:01
  828. X@X@To:    CCRDAVE
  829. X@X@Subj:    
  830. X@X@
  831. X@X@From ucbvax!sdcsvax.ucsd.edu!gr66@sdcc12 Sun Aug 10 13:41:14 1986
  832. X@X@Received: by deneb.UCDAVIS.EDU (4.12/4.7)
  833. X@X@    id AA28769; Sun, 10 Aug 86 13:40:07 pdt
  834. X@X@From: ucbvax!sdcsvax.ucsd.edu!gr66@sdcc12
  835. X@X@Received: by ucdavis.UCDAVIS.EDU (4.12/4.7)
  836. X@X@    id AA24315; Sun, 10 Aug 86 13:41:25 pdt
  837. X@X@Received: by ucbvax.Berkeley.EDU (5.53/1.14)
  838. X@X@    id AA08804; Sun, 10 Aug 86 13:14:35 PDT
  839. X@X@Received: by sdcsvax.ucsd.edu (5.31/4.42)
  840. X@X@    id AA20134; Sun, 10 Aug 86 13:15:05 PDT hops=0
  841. X@X@Received: by sdcc12.ARPA (5.5/4.41)
  842. X@X@    id AA17718; Sun, 10 Aug 86 13:14:43 PDT
  843. X@X@Date: Sun, 10 Aug 86 13:14:43 PDT
  844. X@X@Message-Id: <8608102014.AA17718@sdcc12.ARPA>
  845. X@X@To: ucdavis!deneb!ccrdan
  846. X@X@Status: R
  847. X@X@
  848. X@X@-----------------------------------------------------------------
  849. X@X@
  850. X@X@Dan Gold:
  851. X@X@
  852. X@X@   Here are the 7 files I received in response to my tar read/write
  853. X@X@program request.  This is a DECUS program from Fall, 1985 I think.i
  854. X@X@As TAR.HLP explains, it does not write TAR tapes
  855. X@X@(just reads them) and has a no. of shortcomings.  I tried it and
  856. X@X@it works nicely.  I plan to improve on it a bit so if you 
  857. X@X@ask later I may have more to send you.  Send any questions you have
  858. X@X@about bugs to gordon (address in TAR.HLP).
  859. X@X@
  860. X@X@steve piper
  861. X@X@gr66%sdcc12@sdcsvax.ARPA
  862. X@X@
  863. X@X@TAR.COM
  864. X@X@-------
  865. X@X@
  866. X@X@$ fortran tar
  867. X@X@$ fortran cvt
  868. X@X@$ fortran tapeio
  869. X@X@$ link tar,cvt,tapeio
  870. X@X@
  871. X@X@TAR.CLD
  872. X@X@-------
  873. X@X@
  874. X@X@!**************************************TAR**************************************
  875. X@X@define verb TAR
  876. X@X@   image u$dir:TAR
  877. X@X@   parameter P1 , label=TAPE , prompt="Tape drive"
  878. X@X@      value (required,type=$infile)
  879. X@X@   qualifier FILE
  880. X@X@   qualifier EXTRACT
  881. X@X@   qualifier BINARY
  882. X@X@   qualifier INQUIRE
  883. X@X@   qualifier SECOND_CHANCE
  884. X@X@      default
  885. X@X@   qualifier NAMES
  886. X@X@      value (default="sys$output:",type=$outfile)
  887. X@X@   qualifier LIST
  888. X@X@      value (default="sys$output:",type=$outfile)
  889. X@X@   qualifier VERBOSE
  890. X@X@   qualifier FLATTEN
  891. X@X@      default
  892. X@X@
  893. X@X@TAR.FOR
  894. X@X@-------
  895. X@X@
  896. X@X@c
  897. X@X@c This is tar for VMS, by Gordon Davisson (gordon@uw-june).  It is
  898. X@X@c not based on any liscenced software, and is completely in the
  899. X@X@c public domain.
  900. X@X@c
  901. X@X@c Version 1.0, Gordon Davisson, July 24 1985
  902. X@X@c revised by G.D. July 29 1985 to use io$_rewind right and not abuse rms$_eof
  903. X@X@c revised by G.D. Oct 17 1985 to make sure tape is mounted
  904. X@X@c
  905. X@X@      program tar
  906. X@X@
  907. X@X@      parameter bell = char( 7 ), lf = char( 10 )
  908. X@X@      external cli$_present, cli$_negated, cli$_locpres, cli$_locneg,
  909. X@X@     -    cli$_absent, cli$_defaulted, cli$_normal,
  910. X@X@     -    cli$_comma, cli$_concat
  911. X@X@      include 'tapeio.dck/list'
  912. X@X@      character fname*100, out*128, pstr*9, prot*3, link*1, tmp*1
  913. X@X@      integer*2 i, j, start, finish, flen, olen, files,
  914. X@X@     -    stuff1, stuff2, stuff3, iosb( 2 )
  915. X@X@      integer*4 size, blocks, time, stat,
  916. X@X@     -    cli$get_value, cli$present, sys$assign, sys$qiow
  917. X@X@      logical*1 listing, naming, extracting, binary, inquiring,
  918. X@X@     -    verbose, second_chance, flatten, absent
  919. X@X@
  920. X@X@      absent( stat ) = ( stat .eq. %loc( cli$_absent ) .or.
  921. X@X@     -                   stat .eq. %loc( cli$_negated ))
  922. X@X@c
  923. X@X@c parse command line
  924. X@X@c
  925. X@X@c file -- read from normal file, not a tape
  926. X@X@      stat = cli$present( 'file' )
  927. X@X@      if ( absent( stat )) then
  928. X@X@         tape_file = .true.
  929. X@X@      else if ( .not. stat ) then
  930. X@X@         goto 900
  931. X@X@      else
  932. X@X@        tape_file = .false.
  933. X@X@      end if
  934. X@X@
  935. X@X@c p1 -- tape drive name
  936. X@X@      stat = cli$get_value( 'tape', fname, flen )
  937. X@X@      if ( .not. stat ) goto 900
  938. X@X@      call open_tape( fname( :flen ))
  939. X@X@
  940. X@X@c p2 -- files to extract/list/whatever.  NOT IMPLEMENTED
  941. X@X@c     files = 0
  942. X@X@c     stat = cli$get_value( 'match', fname, flen )
  943. X@X@c     do while ( .not. absent( stat ))
  944. X@X@c        if ( .not. stat ) goto 900
  945. X@X@c        type *, 'File selector: ', fname( :flen )
  946. X@X@c        files = files + 1
  947. X@X@c        stat = cli$get_value( 'match', fname, flen )
  948. X@X@c     end do
  949. X@X@
  950. X@X@c extract -- copy files to disk
  951. X@X@      stat = cli$present( 'extract' )
  952. X@X@      if ( absent( stat )) then
  953. X@X@         extracting = .false.
  954. X@X@      else if ( .not. stat ) then
  955. X@X@         goto 900
  956. X@X@      else
  957. X@X@        extracting = .true.
  958. X@X@      end if
  959. X@X@
  960. X@X@c binary -- copy to disk in block mode
  961. X@X@      stat = cli$present( 'binary' )
  962. X@X@      if ( absent( stat )) then
  963. X@X@         binary = .false.
  964. X@X@      else if ( .not. stat ) then
  965. X@X@         goto 900
  966. X@X@      else
  967. X@X@        binary = .true.
  968. X@X@      end if
  969. X@X@
  970. X@X@c inquire -- ask what to do to each file
  971. X@X@      stat = cli$present( 'inquire' )
  972. X@X@      if ( absent( stat )) then
  973. X@X@         inquiring = .false.
  974. X@X@      else if ( .not. stat ) then
  975. X@X@         goto 900
  976. X@X@      else
  977. X@X@        inquiring = .true.
  978. X@X@      end if
  979. X@X@
  980. X@X@c second_chance -- try to recognize binary files and save them as such
  981. X@X@      stat = cli$present( 'second_chance' )
  982. X@X@      if ( absent( stat )) then
  983. X@X@         second_chance = .false.
  984. X@X@      else if ( .not. stat ) then
  985. X@X@         goto 900
  986. X@X@      else
  987. X@X@        second_chance = .true.
  988. X@X@      end if
  989. X@X@
  990. X@X@c list -- list files on tape
  991. X@X@      stat = cli$get_value( 'list', fname, flen )     
  992. X@X@      if ( absent( stat )) then
  993. X@X@         listing = .false.
  994. X@X@      else if ( .not. stat ) then
  995. X@X@         goto 900
  996. X@X@      else
  997. X@X@         open( listunit, err=920, name=fname( :flen ), type='new',
  998. X@X@     -       defaultfile='tar.lis', carriagecontrol='list' )
  999. X@X@         listing = .true.
  1000. X@X@      end if
  1001. X@X@
  1002. X@X@c verbose -- make a verbose list
  1003. X@X@      stat = cli$present( 'verbose' )
  1004. X@X@      if ( absent( stat )) then
  1005. X@X@         verbose = .false.
  1006. X@X@      else if ( .not. stat ) then
  1007. X@X@         goto 900
  1008. X@X@      else
  1009. X@X@        verbose = .true.
  1010. X@X@      end if
  1011. X@X@
  1012. X@X@c flatten -- extract all files to the current directory
  1013. X@X@      stat = cli$present( 'flatten' )
  1014. X@X@      if ( absent( stat )) then
  1015. X@X@         flatten = .false.
  1016. X@X@      else if ( .not. stat ) then
  1017. X@X@         goto 900
  1018. X@X@      else
  1019. X@X@        flatten = .true.
  1020. X@X@      end if
  1021. X@X@
  1022. X@X@c names -- make a list of what unix filenames mapped to what VMS filenames
  1023. X@X@      stat = cli$get_value( 'names', fname, flen )     
  1024. X@X@      if ( absent( stat )) then
  1025. X@X@         naming = .false.
  1026. X@X@      else if ( .not. stat ) then
  1027. X@X@         goto 900
  1028. X@X@      else
  1029. X@X@         open( nameunit, err=930, name=fname( :flen ), type='new',
  1030. X@X@     -       defaultfile='tar.nam', carriagecontrol='list' )
  1031. X@X@         naming = .true.
  1032. X@X@      end if
  1033. X@X@
  1034. X@X@c
  1035. X@X@c file loop: executed for each file in the archive
  1036. X@X@c
  1037. X@X@      do while ( .true. )
  1038. X@X@   10    using = 0
  1039. X@X@         using2 = 0
  1040. X@X@         call next_block
  1041. X@X@         if ( eof .or. block( curr ) (1:1) .eq. char( 0 )) goto 899
  1042. X@X@
  1043. X@X@c start parsing out a file entry -- parse the header
  1044. X@X@         read( block( curr ), 1001 ) fname, prot, stuff1, stuff2,
  1045. X@X@     -      size, time, stuff3, link
  1046. X@X@ 1001    format( a100, 3x, a3, 2x, 2(o6,2x), 2(o11,1x), o6, 2x, a1 )
  1047. X@X@         blocks = ( size + blocklen - 1 ) / blocklen
  1048. X@X@         flen = index( fname, char( 0 )) - 1
  1049. X@X@         if ( flen .lt. 0 ) flen = len( fname )
  1050. X@X@
  1051. X@X@c add it to the list
  1052. X@X@         if ( listing .and. verbose ) then
  1053. X@X@            call cvt_prot( prot( 1:1 ), pstr( 1:3 ))
  1054. X@X@            call cvt_prot( prot( 2:2 ), pstr( 4:6 ))
  1055. X@X@            call cvt_prot( prot( 3:3 ), pstr( 7:9 ))
  1056. X@X@            write( listunit, 2001 ) pstr, stuff1, stuff2, size,
  1057. X@X@     -          time, fname( :flen )
  1058. X@X@ 2001       format( a9, i3, '/', i3, i7, i11, 1x, a )
  1059. X@X@         else if ( listing ) then
  1060. X@X@            write( listunit, 2002 ) fname( :flen )
  1061. X@X@ 2002       format( a )
  1062. X@X@         end if
  1063. X@X@
  1064. X@X@c ignore links
  1065. X@X@         if ( link .eq. '1' ) goto 10
  1066. X@X@
  1067. X@X@c skip if not extracting
  1068. X@X@         if ( .not. extracting ) goto 40
  1069. X@X@
  1070. X@X@c figure out what to do with the file
  1071. X@X@         if ( inquiring ) then
  1072. X@X@            call lib$get_input( tmp, fname( :flen ) // ': [ynbtq]' )
  1073. X@X@            do while ( index( ' yYnNbBtTqQ', tmp ) .eq. 0 )
  1074. X@X@               call lib$get_input( tmp,
  1075. X@X@     -             bell // fname( :flen ) // ': [ynbtq]' )
  1076. X@X@            end do
  1077. X@X@            call str$upcase( tmp, tmp )
  1078. X@X@            if ( tmp .eq. 'Q' ) goto 899
  1079. X@X@         else
  1080. X@X@            tmp = 'Y'
  1081. X@X@         end if
  1082. X@X@
  1083. X@X@         if ( tmp .eq. 'Y' .or. tmp .eq. ' ' ) then
  1084. X@X@            tmp = 'T'
  1085. X@X@            if ( binary ) tmp = 'B'
  1086. X@X@         else if ( tmp .eq. 'N' ) then
  1087. X@X@            goto 40
  1088. X@X@         end if
  1089. X@X@
  1090. X@X@c parse file name
  1091. X@X@         call cvt_dir_uv( fname( :flen ), out, olen )
  1092. X@X@         if ( flatten ) then
  1093. X@X@            i = index( out( :olen ), ']' )
  1094. X@X@            out = out( i+1:olen )
  1095. X@X@            olen = olen - i
  1096. X@X@         end if
  1097. X@X@         if ( tmp .eq. 'B' ) goto 30
  1098. X@X@
  1099. X@X@c create a text file
  1100. X@X@   20    open( outunit, name=out( :olen ), type='new', recl=maxrecl,
  1101. X@X@     -       defaultfile='.', carriagecontrol='list', err=38 )
  1102. X@X@         if ( size .le. 0 ) then
  1103. X@X@            close( outunit )
  1104. X@X@            goto 99
  1105. X@X@         end if
  1106. X@X@
  1107. X@X@c copy the file to disk
  1108. X@X@         if ( second_chance ) using2 = curr
  1109. X@X@         call next_block
  1110. X@X@         blocks = blocks - 1
  1111. X@X@         start = 1
  1112. X@X@         do while ( size .gt. 0 )
  1113. X@X@            using = curr
  1114. X@X@            finish = index( block( curr ) ( start: ), lf )
  1115. X@X@            do while ( finish .eq. 0 .and. blocks .gt. 0 .and.
  1116. X@X@     -          curr - using + 1 .lt. recblocks )
  1117. X@X@               call next_block
  1118. X@X@               blocks = blocks - 1
  1119. X@X@               if ( eof ) goto 990
  1120. X@X@               finish = index( block( curr ), lf )
  1121. X@X@            end do
  1122. X@X@            if ( finish .eq. 0 ) finish = 2 * blocklen + 1
  1123. X@X@            if ( using .eq. curr ) finish = finish + start - 1
  1124. X@X@            i = start + blocklen * (using-1)
  1125. X@X@            j = finish + blocklen * (curr-1)
  1126. X@X@            start = finish + 1
  1127. X@X@            size = size - j + i - 1
  1128. X@X@            if ( size .lt. 0 ) then
  1129. X@X@               j = j + size
  1130. X@X@               size = 0
  1131. X@X@            end if
  1132. X@X@            if ( using2 .ne. 0 .and. j - i .gt. maxrecl ) then
  1133. X@X@               type *, 'Giving ', fname( :flen ), ' a second chance...'
  1134. X@X@               blocks = blocks + curr - using2
  1135. X@X@               curr = using2
  1136. X@X@               using = 0
  1137. X@X@               using2 = 0
  1138. X@X@               close( outunit, dispose='delete' )
  1139. X@X@               goto 30
  1140. X@X@            end if
  1141. X@X@            write( outunit, 2005, err=39, iostat=stat )
  1142. X@X@     -          buffer( i : j-1 )
  1143. X@X@2005        format( a )
  1144. X@X@            if ( curr - using2 .ge. saveblocks ) using2 = 0
  1145. X@X@         end do
  1146. X@X@
  1147. X@X@         close( outunit )
  1148. X@X@         goto 99
  1149. X@X@
  1150. X@X@c create a binary file
  1151. X@X@   30    using = 0
  1152. X@X@         using2 = 0
  1153. X@X@         open( outunit, name=out( :olen ), type='new',
  1154. X@X@     -       recl=blocklen, recordtype='fixed', defaultfile='.',
  1155. X@X@     -       carriagecontrol='none', err=39 )
  1156. X@X@
  1157. X@X@         do while ( blocks .gt. 0 )
  1158. X@X@            call next_block
  1159. X@X@            blocks = blocks - 1
  1160. X@X@            write( outunit, 3001, err=39, iostat=stat ) block( curr )
  1161. X@X@ 3001       format( a )
  1162. X@X@         end do
  1163. X@X@         close( outunit )
  1164. X@X@         goto 99
  1165. X@X@
  1166. X@X@c got an error creating the file: skip it.
  1167. X@X@   38    type *, 'Error creating ', out( :olen ), ' skipping...'
  1168. X@X@         goto 40
  1169. X@X@
  1170. X@X@c got an error writing the file: skip the rest of it.
  1171. X@X@   39    type *, 'Error writing ', out( :olen ), ' skipping...'
  1172. X@X@         close( outunit, dispose='delete' )
  1173. X@X@
  1174. X@X@c skip the file
  1175. X@X@   40    using = 0
  1176. X@X@         using2 = 0
  1177. X@X@         do i = 1, blocks
  1178. X@X@            call next_block
  1179. X@X@            if ( eof ) goto 990
  1180. X@X@         end do
  1181. X@X@         goto 10
  1182. X@X@
  1183. X@X@c successfully copied file to disk: enter it in the names file
  1184. X@X@   99    if ( naming ) write( nameunit, 2000 ) out( :olen ),
  1185. X@X@     -       fname( :flen )
  1186. X@X@ 2000    format( a, ' -> ', a )
  1187. X@X@
  1188. X@X@      end do
  1189. X@X@
  1190. X@X@c end of tape: close it and exit!
  1191. X@X@  899 close( inunit )
  1192. X@X@      call exit
  1193. X@X@
  1194. X@X@c
  1195. X@X@c fatal errors
  1196. X@X@c
  1197. X@X@  900 type *, 'Error parsing command line'
  1198. X@X@      call exit
  1199. X@X@
  1200. X@X@  920 type *, 'Error opening listing file, ', fname( :flen )
  1201. X@X@      call exit
  1202. X@X@
  1203. X@X@  930 type *, 'Error opening names file, ', fname( :flen )
  1204. X@X@      call exit
  1205. X@X@
  1206. X@X@  990 type *, 'Premature end of tape while reading ', fname( :flen )
  1207. X@X@      call exit
  1208. X@X@
  1209. X@X@      end
  1210. X@X@
  1211. X@X@
  1212. X@X@
  1213. X@X@TAPEIO.FOR
  1214. X@X@----------
  1215. X@X@
  1216. X@X@c
  1217. X@X@c this routine accesses, checks, and rewinds the specified tape (or file,
  1218. X@X@c if tape_file is true.
  1219. X@X@c
  1220. X@X@      subroutine open_tape( name )
  1221. X@X@
  1222. X@X@      include 'tapeio.dck/list'
  1223. X@X@      include '($iodef)/nolist'
  1224. X@X@      include '($dvidef)/nolist'
  1225. X@X@      include '($devdef)/nolist'
  1226. X@X@      character*(*) name
  1227. X@X@
  1228. X@X@      integer*2 iosb( 2 ), devreq_w( 2 )
  1229. X@X@      integer*4 stat, devreq( 4 ), devchar, sys$assign, sys$qiow,
  1230. X@X@     -    sys$getdvi
  1231. X@X@
  1232. X@X@      equivalence ( devreq, devreq_w )
  1233. X@X@      data devreq_w, devreq( 3 ), devreq( 4 )
  1234. X@X@     -    / 4, dvi$_devchar, 0, 0 /
  1235. X@X@
  1236. X@X@      if ( tape_file ) then
  1237. X@X@         stat = sys$assign( name, channel,, )
  1238. X@X@         if ( .not. stat ) goto 900
  1239. X@X@         devreq( 2 ) = %loc( devchar )
  1240. X@X@         stat = sys$getdvi( , channel,, devreq, iosb,,, )
  1241. X@X@         if ( .not. stat ) goto 900
  1242. X@X@         stat = iosb( 1 )
  1243. X@X@         if ( .not. stat ) goto 900
  1244. X@X@         if ( .not. btest( devchar, dev$v_avl )) goto 910
  1245. X@X@         if ( .not. btest( devchar, dev$v_for )) goto 920
  1246. X@X@         stat = sys$qiow( , %val( channel ), %val( io$_rewind ),
  1247. X@X@     -       iosb,,,,,,,, )
  1248. X@X@         if ( .not. stat ) goto 930
  1249. X@X@         stat = iosb( 1 )
  1250. X@X@         if ( .not. stat ) goto 930
  1251. X@X@      else
  1252. X@X@         open( inunit, err=950, name=name,
  1253. X@X@     -       type='old', readonly )
  1254. X@X@      end if
  1255. X@X@
  1256. X@X@      return
  1257. X@X@
  1258. X@X@c
  1259. X@X@c fatal errors
  1260. X@X@c
  1261. X@X@  900 type *, 'Error accessing tape, ', name( :flen )
  1262. X@X@      call exit( stat )
  1263. X@X@  910 type *, 'Tape offline or not available.'
  1264. X@X@      call exit
  1265. X@X@  920 type *, 'Tape must be mounted /foreign.'
  1266. X@X@      call exit
  1267. X@X@  930 type *, 'Error rewinding tape.'
  1268. X@X@      call exit( stat )
  1269. X@X@
  1270. X@X@  950 type *, 'Error opening input file, ', name( :flen )
  1271. X@X@      call exit
  1272. X@X@
  1273. X@X@      end
  1274. X@X@
  1275. X@X@c
  1276. X@X@c this routine makes sure the next block is available, reading it from
  1277. X@X@c tape if necessary.
  1278. X@X@c
  1279. X@X@      subroutine next_block
  1280. X@X@      include 'tapeio.dck'
  1281. X@X@      integer*2 blen, u, i, iosb( 4 )
  1282. X@X@      integer*4 stat, sys$qiow
  1283. X@X@      data curr, blen / 0, 0 /
  1284. X@X@
  1285. X@X@      eof = .false.
  1286. X@X@      curr = curr + 1
  1287. X@X@      if ( curr .le. blen / blocklen ) return
  1288. X@X@
  1289. X@X@      if ( using2 .le. 0 ) then
  1290. X@X@         u = using
  1291. X@X@      else if ( using .le. 0 ) then
  1292. X@X@         u = using2
  1293. X@X@      else
  1294. X@X@         u = min( using, using2 )
  1295. X@X@      end if
  1296. X@X@
  1297. X@X@      if ( u .gt. blen / blocklen ) then
  1298. X@X@         type *, 'Internal error.  Call the debugger.'
  1299. X@X@         call exit
  1300. X@X@      else if ( u .gt. 1 ) then
  1301. X@X@         buffer( 1 : blen - blocklen*(u-1)) =
  1302. X@X@     -       buffer( 1+blocklen*(u-1) : blen )
  1303. X@X@         blen = blen - blocklen*(u-1)
  1304. X@X@         curr = curr - u + 1
  1305. X@X@         using = using - u + 1
  1306. X@X@         using2 = using2 - u + 1
  1307. X@X@      else if ( u .lt. 1 ) then
  1308. X@X@         blen = 0
  1309. X@X@         curr = 1
  1310. X@X@      end if
  1311. X@X@
  1312. X@X@      do while ( curr .gt. blen / blocklen )
  1313. X@X@         if ( tape_file ) then
  1314. X@X@            stat = sys$qiow( , %val( channel ), %val( io$_readlblk ),
  1315. X@X@     -          iosb,,, %ref( buffer( blen+1: )), %val( maxlen-blen )
  1316. X@X@     -          ,,,, )
  1317. X@X@            if ( .not. stat ) then
  1318. X@X@               type *, 'Error reading from tape'
  1319. X@X@               call exit( stat )
  1320. X@X@            else if ( .not. iosb( 1 )) then
  1321. X@X@               type *, 'Error reading from tape'
  1322. X@X@               call exit( iosb( 1 ))
  1323. X@X@            else if ( iosb( 2 ) .eq. 0 ) then
  1324. X@X@               goto 99
  1325. X@X@            endif
  1326. X@X@            blen = blen + iosb( 2 )
  1327. X@X@         else
  1328. X@X@            read( inunit, 10, end=99 ) i, buffer( blen+1: )
  1329. X@X@   10       format( q, a )
  1330. X@X@            blen = blen + i
  1331. X@X@         end if
  1332. X@X@         if ( blen .gt. maxlen ) then
  1333. X@X@            type *, 'Blocking factor too large.'
  1334. X@X@            call exit
  1335. X@X@         end if
  1336. X@X@      end do
  1337. X@X@      return
  1338. X@X@
  1339. X@X@99    curr = curr - 1
  1340. X@X@      eof = .true.
  1341. X@X@      return
  1342. X@X@      end
  1343. X@X@
  1344. X@X@
  1345. X@X@
  1346. X@X@TAPEIO.DCK
  1347. X@X@----------
  1348. X@X@c
  1349. X@X@c parameters:
  1350. X@X@c   blocklen is the size of the units tar works with
  1351. X@X@c   saveblocks is the number of blocks into the file saved for a second chance
  1352. X@X@c   maxrecl is the maximum length of record a text can have
  1353. X@X@c   maxblockfactor is the maximum blocking factor this program can deal with
  1354. X@X@c
  1355. X@X@      parameter blocklen = 512, saveblocks = 5, maxrecl = 512,
  1356. X@X@     -    maxblockfactor = 20
  1357. X@X@
  1358. X@X@c secondary parameters calculated from those above
  1359. X@X@      parameter recblocks = 2 + maxrecl/blocklen,
  1360. X@X@     -   maxblocks = maxblockfactor + saveblocks + recblocks,
  1361. X@X@     -   maxlen = blocklen*maxblocks
  1362. X@X@
  1363. X@X@c these are numbers for fortran units to be used for various files
  1364. X@X@      parameter inunit = 1, outunit = 2, listunit = 3, nameunit = 4
  1365. X@X@
  1366. X@X@c
  1367. X@X@c variables:
  1368. X@X@c
  1369. X@X@c i/o control stuff
  1370. X@X@      integer*2 channel
  1371. X@X@      logical*1 tape_file
  1372. X@X@
  1373. X@X@c this is the buffer records get read into
  1374. X@X@      character buffer*( maxlen ), block( maxblocks )*( blocklen )
  1375. X@X@      equivalence ( buffer, block )
  1376. X@X@
  1377. X@X@c control info for the buffer
  1378. X@X@      integer*2 using, using2, curr
  1379. X@X@      logical*1 eof
  1380. X@X@
  1381. X@X@
  1382. X@X@      common /commonbuf/ buffer
  1383. X@X@      common /commonints/ using, using2, curr, eof, tape_file, channel
  1384. X@X@
  1385. X@X@
  1386. X@X@CVT.FOR
  1387. X@X@-------
  1388. X@X@
  1389. X@X@c
  1390. X@X@c this subroutine converts a complete filespec (directory+file) name from
  1391. X@X@c unix format to VMS
  1392. X@X@c
  1393. X@X@      subroutine cvt_dir_uv( unix, vms, vlen )
  1394. X@X@
  1395. X@X@      parameter reserved = 10
  1396. X@X@      character*(*) unix, vms
  1397. X@X@      integer*2 vlen, i, j
  1398. X@X@
  1399. X@X@      vms( 1:1 ) = '['
  1400. X@X@      vlen = 1
  1401. X@X@      i = 1
  1402. X@X@      if ( unix( 1:1 ) .eq. '/' ) i = 2
  1403. X@X@      j = index( unix( i: ), '/' )
  1404. X@X@      do while ( j .ne. 0 )
  1405. X@X@         vms( vlen+1:vlen+1 ) = '.'
  1406. X@X@         call cvt_string_uv( unix( i : i+j-2 ), vms( vlen+2: ), k )
  1407. X@X@         i = i + j
  1408. X@X@         j = index( unix( i: ), '/' )
  1409. X@X@         vlen = vlen + k + 1
  1410. X@X@         if ( vlen + reserved .gt. len( vms )) then
  1411. X@X@            vlen = len( vms ) - reserved
  1412. X@X@            if ( vms( vlen:vlen ) .eq. '.' ) vlen = vlen - 1
  1413. X@X@            do while ( j .ne. 0 )
  1414. X@X@               i = i + j
  1415. X@X@               j = index( unix( i: ), '/' )
  1416. X@X@            end do
  1417. X@X@         end if
  1418. X@X@      end do
  1419. X@X@
  1420. X@X@      if ( vlen .eq. 1 ) then
  1421. X@X@         vlen = 0
  1422. X@X@      else
  1423. X@X@         vlen = vlen + 1
  1424. X@X@         vms( vlen:vlen ) = ']'
  1425. X@X@      end if
  1426. X@X@
  1427. X@X@      call cvt_file_uv( unix( i: ), vms( vlen+1: ), k )
  1428. X@X@      vlen = vlen + k
  1429. X@X@      return
  1430. X@X@
  1431. X@X@      end      
  1432. X@X@
  1433. X@X@c
  1434. X@X@c this subroutine converts an individual file name from unix format to VMS
  1435. X@X@c
  1436. X@X@      subroutine cvt_file_uv( unix, vms, vlen )
  1437. X@X@
  1438. X@X@      parameter mlen1 = 64, mlen2 = 64
  1439. X@X@c     parameter mlen1 = 9, mlen2 = 3       ! for version 3 and before
  1440. X@X@      character*(*) unix, vms
  1441. X@X@      integer*2 vlen, i, j
  1442. X@X@
  1443. X@X@      i = index( unix, '.' )
  1444. X@X@      if ( i .eq. 0 ) i = len( unix ) + 1
  1445. X@X@
  1446. X@X@      call cvt_string_uv( unix( :i-1 ), vms, j )
  1447. X@X@      if ( j .gt. mlen1 ) j = mlen1
  1448. X@X@      vlen = j + 1
  1449. X@X@      if ( vlen .gt. len( vms )) vlen = len( vms )
  1450. X@X@      vms( vlen:vlen ) = '.'
  1451. X@X@
  1452. X@X@      if ( i .ge. len( unix )) return
  1453. X@X@
  1454. X@X@      call cvt_string_uv( unix( i+1: ), vms( vlen+1: ), j )
  1455. X@X@      if ( j .gt. mlen2 ) j = mlen2
  1456. X@X@      vlen = vlen + j
  1457. X@X@      return
  1458. X@X@
  1459. X@X@      end
  1460. X@X@
  1461. X@X@c
  1462. X@X@c this subroutine converts a string to characters that can appear in
  1463. X@X@c VMS filenames
  1464. X@X@c
  1465. X@X@c if you're using a version 3 or pervious VMS system, you'll have to
  1466. X@X@c rewrite this to avoid _ and $.
  1467. X@X@c
  1468. X@X@      subroutine cvt_string_uv( unix, vms, vlen )
  1469. X@X@
  1470. X@X@      character*(*) unix, vms, c*1
  1471. X@X@      integer*2 vlen, i
  1472. X@X@
  1473. X@X@      vms = unix
  1474. X@X@      vlen = min( len( unix ), len( vms ))
  1475. X@X@      do i = 1, vlen
  1476. X@X@         c = vms( i:i )
  1477. X@X@         if ( 'A' .le. c .and. c .le. 'Z' .or.
  1478. X@X@     -        '0' .le. c .and. c .le. '9' .or.
  1479. X@X@     -        c .eq. '_' .or. c .eq. '$'  ) then
  1480. X@X@            continue
  1481. X@X@         else if ( 'a' .le. c .and. c .le. 'z' ) then
  1482. X@X@            vms( i:i ) = char( ichar( c ) - 32 )
  1483. X@X@         else if ( c .eq. '-' ) then
  1484. X@X@            vms( i:i ) = '_'
  1485. X@X@         else
  1486. X@X@            vms( i:i ) = '$'
  1487. X@X@         end if
  1488. X@X@      end do
  1489. X@X@
  1490. X@X@      return
  1491. X@X@
  1492. X@X@      end
  1493. X@X@
  1494. X@X@c
  1495. X@X@c this souroutine converts an octal digit to a 3-character protection mask
  1496. X@X@c
  1497. X@X@      subroutine cvt_prot( c, out )
  1498. X@X@
  1499. X@X@      character c*1, out*3, mask( 8 )*3
  1500. X@X@      data mask / '---', '--x', '-w-', '-wx',
  1501. X@X@     -            'r--', 'r-x', 'rw-', 'rwx' /
  1502. X@X@
  1503. X@X@      out = mask( ichar( c ) - ichar( '0' ) + 1 )
  1504. X@X@      return
  1505. X@X@
  1506. X@X@      end
  1507. X@X@
  1508. X@X@
  1509. X@X@
  1510. X@X@TAR.HLP
  1511. X@X@-------
  1512. X@X@
  1513. X@X@
  1514. X@X@1 TAR
  1515. X@X@  Invokes the tape archive reader to read unix-format tapes.
  1516. X@X@
  1517. X@X@  Format:
  1518. X@X@
  1519. X@X@    TAR tape-name[:]
  1520. X@X@2 Parameter
  1521. X@X@
  1522. X@X@ tape-name[:]
  1523. X@X@
  1524. X@X@  Specifies the device name of the tape drive the archive is mounted on.
  1525. X@X@  The archive must be mounted foreign.
  1526. X@X@
  1527. X@X@  If the /FILE qualifier is specified, this parameter is interpreted as
  1528. X@X@  the file name for the archive.
  1529. X@X@2 Command_Qualifiers
  1530. X@X@
  1531. X@X@/BINARY
  1532. X@X@
  1533. X@X@  Specifies that the files extracted should be put into fixed-length-512-
  1534. X@X@  byte-record files and that no interpretation should be preformed on
  1535. X@X@  the contents.
  1536. X@X@
  1537. X@X@/EXTRACT
  1538. X@X@
  1539. X@X@  Specifies that the files in the archive should be copied into the
  1540. X@X@  directory, or subdirectories (depending on the /FLATTEN qualifier).
  1541. X@X@
  1542. X@X@/FILE
  1543. X@X@
  1544. X@X@  Specifies that, instead of a tape, the archive is contained in a normal
  1545. X@X@  file.
  1546. X@X@
  1547. X@X@/FLATTEN (D)
  1548. X@X@
  1549. X@X@  Specifies that files extracted from the archive should be put in the
  1550. X@X@  default directory even when the files would normally be put in
  1551. X@X@  subdirectories.
  1552. X@X@
  1553. X@X@  This qualifier is on by default because the program is incapable of
  1554. X@X@  creating subdirectories to put the extracted files in, so unless they
  1555. X@X@  exist already, /NOFLATTEN in a pure loss.
  1556. X@X@
  1557. X@X@/INQUIRE
  1558. X@X@
  1559. X@X@  Tells the program to ask the user what to do with each file it has been
  1560. X@X@  told to extract.  The program prompts with the filename followed by a
  1561. X@X@  list of options.  The options are:
  1562. X@X@
  1563. X@X@     y - extract the file normally
  1564. X@X@     n - skip the file
  1565. X@X@     t - extract the file in text (not binary) mode
  1566. X@X@     b - extract the file in binary mode
  1567. X@X@     q - exit the program
  1568. X@X@
  1569. X@X@  The y option is equivalent t or b depending on whether the /BINARY
  1570. X@X@  qualifier was given.
  1571. X@X@
  1572. X@X@/LIST
  1573. X@X@
  1574. X@X@ /LIST=filename (default = sys$output:)
  1575. X@X@
  1576. X@X@  Tells the program to create a list of all of the files on the tape.
  1577. X@X@  If the /VERBOSE qualifier is also specified, the list contains more
  1578. X@X@  than just the file names.
  1579. X@X@
  1580. X@X@/NAMES
  1581. X@X@
  1582. X@X@ /NAMES=filename (default = sys$output:)
  1583. X@X@
  1584. X@X@  If files are extracted, the program creates a file giving the names
  1585. X@X@  of the files on the tape and the VMS filenames they were mapped into
  1586. X@X@  when extracted.
  1587. X@X@
  1588. X@X@/SECOND_CHANCE (D)
  1589. X@X@
  1590. X@X@  This specifies that if a file is being extracted in text mode, and
  1591. X@X@  a line longer then 512 bytes in encountered sufficiently near the
  1592. X@X@  beginning of the file, it should be re-extracted in binary mode.
  1593. X@X@
  1594. X@X@  If negated, files with long lines are discarded in text mode.
  1595. X@X@
  1596. X@X@/VERBOSE
  1597. X@X@
  1598. X@X@  This specifies that lists should contain more information than just
  1599. X@X@  the filename.
  1600. X@X@
  1601. X@X@2 Bugs
  1602. X@X@  Here's a list of some of the more noticable bugs and deficiencies:
  1603. X@X@     - It can't write tar tapes.
  1604. X@X@     - It can't operate on only some of the files on a tape.
  1605. X@X@     - Verbose listings contain the date in seconds since 1970 or so,
  1606. X@X@         rather than any reasonable format.
  1607. X@X@     - It can't create subdirectories to put files in. (that's why
  1608. X@X@         /FLATTEN is the default)
  1609. X@X@     - Error recovery and reporting could use improvement.
  1610. X@X@     - probably others I can't think of at the moment.
  1611. X@X@
  1612. X@X@  If you discover more bugs, fix them, or just have suggestions, mail
  1613. X@X@  them to Gordon Davisson ({ihnp4|decvax}!uw-beaver!uw-june!gordon, or
  1614. X@X@  gordon@uw-june.ARPA).
  1615. X@X@
  1616. X@X@  I'll probably fix some of these eventually, in which case I'll post
  1617. X@X@  the new version to net.sources.
  1618. X@X@----------------------------------------------------------------
  1619. X@X@
  1620.  
  1621.  
  1622.