-+-+-+-+-+-+-+-+ START OF PART 4 -+-+-+-+-+-+-+-+
X         close (archive) ;
X         open (archive, 'HEADER.TAR', history := NEW,
X            default := sys$scratch_kt) ;
X         rewrite (archive) ;
X         write (archive, header) ;
X         close (archive) ;
X         LIB$STOP (tar__badheader) ;
X         END ;
X
X
X   `7B Calculate the checksum of an archive record.  If the record is all nu
Vll,
X     0 is returned.  If the record is a header record and the checksum in
X     the header is correct, the checksum is returned.  Otherwise, -1 is
X     returned. `7D
X
X   FUNCTION checksum (
X      VAR header_record : `5BREADONLY`5D tar_record_type)
X         : integer ;
X
X      CONST
X         `7B A TAR checksum is computed with the checksum field temporarily
X           filled with spaces. `7D
X         constant_part = size (header_record.chksum) * ord (space) ;
X
X      VAR
X         sum, header_sum : integer ;
X         upto : integer ;
X
X      BEGIN
X         header_sum := -1 ;
X         readv (header_record.chksum.value, header_sum:oct,
X            error := CONTINUE) ;
X         IF header_sum <> -1 THEN BEGIN
X            sum := constant_part ;
X            upto := byte_offset (tar_record_type, chksum) - 1 ;
X            FOR i := 1 TO upto DO
X               sum := sum + ord (header_record.data`5Bi`5D) ;
X            FOR i := byte_offset (tar_record_type, linkflag)
X            TO tar_record_size DO
X               sum := sum + ord (header_record.data`5Bi`5D) ;
X            IF sum = header_sum THEN
X               checksum := header_sum
X            ELSE
X               checksum := -1 END
X         ELSE BEGIN
X            sum := 0 ;
X            FOR i := 1 TO tar_record_size DO
X               sum := sum + ord (header_record.data`5Bi`5D) ;
X            IF sum = 0 THEN      `7B We have a null record `7D
X               checksum := 0
X            ELSE
X               checksum := -1 END END ;
X
X
X   FUNCTION inspect_header (
X      VAR header_record : `5BREADONLY`5D tar_record_type ;
X      VAR file_spec : filespec_type ;
X      VAR file_size : integer ;
X      VAR file_mtime : unsigned ;
X      VAR file_mode : file_mode_type ;
X      VAR directory : boolean ;
X      VAR link : boolean ;
X      VAR link_spec : filespec_type) : boolean ;
X
X      VAR
X         tar_filespec : medium_string ;
X         header_tmp : tar_record_type ;
X         header_checksum : integer ;
X         i : integer ;
X         response : char ;
X
X      BEGIN
X         header_checksum := checksum (header_record) ;
X         IF header_checksum > 0 THEN BEGIN
X            inspect_header := true ;
X            convert_zstr (header_record.name, file_spec) ;
X            inspecting_header := true ;
X            readv (header_record.siz, file_size:oct) ;
X            readv (header_record.mtime, file_mtime:oct) ;
X            readv (header_record.mode.value, file_mode.value:oct) ;
X            inspecting_header := false ;
X            directory := false ;
X            IF file_mode.mask`5B10`5D THEN
X               IF file_size = 0 THEN
X                  directory := true
X               ELSE
X                  bad_header (header_record)
X            ELSE
X               IF (file_spec`5Bfile_spec.length`5D = slash)
X               AND (file_size = 0) THEN
X                  directory := true ;
X            link := (header_record.linkflag = '1')
X               OR (header_record.linkflag = '2') ;
X            IF link THEN
X               convert_zstr (header_record.linkname, link_spec) END
X         ELSE BEGIN
X            inspect_header := false ;
X            IF header_checksum = 0 THEN      `7B TAR's EOF marker `7D
X               eof_mark_found := true END END ;
X
X
X   FUNCTION scan_to_next_header (
X      file_size : integer := -1) : boolean ;
X
X      VAR
X         skip_count, i : integer ;
X         more_to_scan : boolean ;
X
X      BEGIN
X         scan_to_next_header := true ;
X
X      `7B Assume archive`5E contains header prior to next header `7D
X
X         IF file_size = -1 THEN
X            readv (archive`5E.siz, file_size:oct) ;
X         IF file_size = 0 THEN
X            skip_count := 1
X         ELSE
X            skip_count := ((file_size - 1) DIV tar_record_size) + 2 ;
X         i := 0 ;
X         more_to_scan := true ;
X         WHILE more_to_scan DO
X            IF i = skip_count THEN more_to_scan := false
X            ELSE
X               IF eof (archive) THEN BEGIN
X                  more_to_scan := false ;
X                  scan_to_next_header := false END
X               ELSE BEGIN
X                  get (archive) ;
X                  i := i + 1 END ;
X         END ;
X
X
X   PROCEDURE collect_matches (
X      VAR match_chain : match_node_pointer) ;
X
X      VAR
X         current_ptr, tmp_ptr : match_node_pointer ;
X         filespec : filespec_type ;
X         first_time : boolean ;
X         i : integer ;
X
X      BEGIN
X         first_time := true ;
X         WHILE success (CLI$GET_VALUE (filespec_kt, filespec)) DO BEGIN
X            `7B Don't look for any corresponding "dispose" calls ... `7D
X            new (current_ptr) ;
X            IF first_time THEN BEGIN
X               match_chain := current_ptr ;
X               first_time := false END
X            ELSE
X               tmp_ptr`5E.next := current_ptr ;
X
X            i := 1 ;
X            WHILE i <= filespec.length DO BEGIN
X               current_ptr`5E.string`5Bi`5D := filespec`5Bi`5D ;
X               i := i + 1 END ;
X            current_ptr`5E.string`5Bi`5D := null ;
X
X            current_ptr`5E.literal := cli_present (literal_kt) ;
X            tmp_ptr := current_ptr END ;
X         current_ptr`5E.next := nil END ;
X
X
X   FUNCTION match_filespec (
X      cand_spec : filespec_type ;
X      match_chain : match_node_pointer) : boolean ;
X
X      VAR
X         current_ptr : match_node_pointer ;
X         match : boolean ;
X         i : integer ;
X         cand_slashes, match_slashes : integer ;
X
X      BEGIN
X         IF match_all THEN
X            match_filespec := true
X         ELSE BEGIN
X            cand_spec := cand_spec + null ;
X            current_ptr := match_chain ;
X            match := false ;
X            WHILE NOT match AND (current_ptr <> nil) DO BEGIN
X               IF current_ptr`5E.literal THEN
X                  IF current_ptr`5E.string`5Bcand_spec.length`5D = null THEN
V BEGIN
X                     i := 1 ;
X                     match := true ;
X                     WHILE match AND (i < cand_spec.length) DO BEGIN
X                        match := current_ptr`5E.string`5Bi`5D = cand_spec`5B
Vi`5D ;
X                        i := i + 1 END END
X                  ELSE
X               ELSE BEGIN
X                  match := SHELL$MATCH_WILD (cand_spec.body,
X                     current_ptr`5E.string) ;
X                  IF match THEN BEGIN
X                     cand_slashes := 0 ;
X                     i := 1 ;
X                     WHILE cand_spec`5Bi`5D <> null DO BEGIN
X                        IF cand_spec`5Bi`5D = slash THEN
X                           cand_slashes := cand_slashes + 1 ;
X                        i := i + 1 END ;
X                     match_slashes := 0 ;
X                     i := 1 ;
X                     WHILE current_ptr`5E.string`5Bi`5D <> null DO BEGIN
X                        IF current_ptr`5E.string`5Bi`5D = slash THEN
X                           match_slashes := match_slashes + 1 ;
X                        i := i + 1 END ;
X                     match := cand_slashes = match_slashes END END ;
X               IF NOT match THEN
X                  current_ptr := current_ptr`5E.next END ;
X            match_filespec := match END END ;
X
X
X   `5BEXTERNAL`5D PROCEDURE tar_list (
X      VAR archive_filespec : `5BREADONLY`5D filespec_type ;
X      full : boolean) ; external ;
X
X   `5BEXTERNAL`5D PROCEDURE tar_extract (
X      VAR archive_filespec : `5BREADONLY`5D filespec_type ;
X      confirm : boolean) ; external ;
X
X   `5BEXTERNAL`5D PROCEDURE tar_write (
X      VAR archive_filespec : `5BREADONLY`5D filespec_type ;
X      confirm : boolean ;
X      scan : boolean ;
X      map_mode : map_mode_type ;
X      appending : boolean := false ;
X      retain_version : boolean := false) ; external ;
X
X   `5BEXTERNAL`5D PROCEDURE tar_append (
X      VAR archive_filespec : `5BREADONLY`5D filespec_type ;
X      confirm : boolean ;
X      scan : boolean ;
X      map_mode : map_mode_type ;
X      retain_version : boolean := false) ; external ;
X
X
X   FUNCTION get_map_mode : map_mode_type ;
X      VAR
X         mode_str : small_string ;
X      BEGIN
X         lib_sigiferr (CLI$GET_VALUE (map_mode_kt, mode_str)) ;
X         CASE mode_str`5B1`5D OF
X            'P' : get_map_mode := prefix_mode ;
X            'A' : get_map_mode := absolute_mode ;
X            'R' : get_map_mode := root_mode END END ;
X
X
X   BEGIN    `7B tar `7D
X      establish (tar_handler) ;
X      delta_seconds := get_timezone ;`09`09`7B Read logical TAR_TIMEZONE `7D
X
X      `7B Get archive name `7D
X      IF cli_present (archive_kt) THEN
X         lib_sigiferr (CLI$GET_VALUE (%DESCR archive_kt, archive_filespec))
X      ELSE
X         archive_filespec := 'TAR_ARCHIVE' ;
X
X      lib_sigiferr (CLI$GET_VALUE (option_kt, option)) ;
X      CASE option`5B1`5D OF    `7B case selector must be an ordinal type `7D
X         'E' :
X            tar_extract (archive_filespec, cli_present (confirm_kt)) ;
X         'W' :
X            tar_write (archive_filespec, cli_present (confirm_kt),
X               cli_present (scan_kt), get_map_mode,, cli_present (version_kt
V)) ;
X         'A' :
X            tar_append (archive_filespec, cli_present (confirm_kt),
X               cli_present (scan_kt), get_map_mode, cli_present (version_kt)
V) ;
X         'L' : BEGIN
X            IF cli_present (output_kt) THEN BEGIN
X               lib_sigiferr (CLI$GET_VALUE (output_kt, output_filespec)) ;
X               open (output, output_filespec, history := NEW,
X                  default := 'TAR.LIS') ;
X               rewrite (output) END ;
X            tar_list (archive_filespec, cli_present (full_kt)) END END ;
X      END.
$ CALL UNPACK TAR.PAS;1 508984364
$ create 'f'
X! TARMSG.MSG -`09TAR message definitions
X!
X! Copyright:`09Copyright 1989,1990, Victoria College Computer Services.
X!`09`09All rights reserved except those granted in the file
X!`09`09AAAREADME.1ST, which is distributed with this file.
X!
X! Author:`09Tim Cook (timcc@viccol.edu.au)
X
X! The 105 in the following .FACILITY directive can be changed, but the
X! /PREFIX must be TAR__.
X
X.FACILITY`09TAR, 105 /PREFIX=TAR__
X
X.BASE 256
X.SEVERITY`09SUCCESS`09`09! 256 messages in this group
XCREATED`09`09<created !AS (!SL record!%S)> /FAO=2
XCREATEDIR`09<created directory !AS> /FAO=1
XWRITTEN`09`09<written !AS (!SL byte!%S)> /FAO=2
XWRITDIR`09`09<written directory !AS> /FAO=1
XAPPENDED`09<appended !AS (!SL byte!%S)> /FAO=2
XAPPENDIR`09<appended directory !AS> /FAO=1
XTOTCREAT`09<total of !SL file!%S created, !SL file!%S scanned> /FAO=2
XTOTWRITE`09<total of !SL file!%S written> /FAO=1
XTOTAPPEND`09<total of !SL file!%S appended> /FAO=1
X
X.BASE 512
X.SEVERITY`09INFORMATIONAL`09! 256 messages in this group
XEMPTY`09`09<file "!AS" empty, no output file created> /FAO=1
XHARDLINK`09<file "!AS" is a link to "!AS", !/!_no output file created> -
X`09`09   /FAO=2
XSYMLINK`09`09<file "!AS" is a link to "!AS", !/!_no output file created> -
X`09`09   /FAO=2
X
X.BASE 768
X.SEVERITY`09WARNING`09`09! 256 messages in this group
XNOFILES`09`09<no files selected from !AS> /FAO=1
XWRAPPED`09`09<records in file !AS longer than !UL byte!%S have been wrapped>
V -
X`09`09   /FAO=1
XRECTOOLONG`09<record size of !UL too large for input buffer> /FAO=1
X
X.BASE 1024
X.SEVERITY`09ERROR`09`09! 256 messages in this group
XERRCREDIR`09<error creating directory !AS> /FAO=1
X
X.BASE 1280
X.SEVERITY`09FATAL
XBADHEADER`09<bad header record, dumped in file SYS$SCRATCH:HEADER.TAR>
XBADARCHIVE`09<!AS is not a valid TAR archive> /FAO=1
XPARSE`09`09<error parsing !AS> /FAO=1
XOPENIN`09`09<error opening !AS for input> /FAO=1
XCLOSE`09`09<error closing !AS> /FAO=1
XCREATERR`09<error creating !AS> /FAO=1
X! Converted from PAS$_ERRDURGET
XERRREAD`09`09<error reading !+!+!AS> /FAO=3
XERRWRITE`09<error writing !AS> /FAO=1
XINVTIMZON`09<invalid timezone value "!AS"> /FAO=1
XINTERNERR`09<internal error, code !8XL, notify System Administrator> /FAO=1
$ CALL UNPACK TARMSG.MSG;1 1091982611
$ create 'f'
X`7B TAR_EXTRACT.PAS -`09Routines to support TAR/EXTRACT
X!
X! Copyright:`09Copyright 1989,1990, Victoria College Computer Services.
X!`09`09All rights reserved except those granted in the file
X!`09`09AAAREADME.1ST, which is distributed with this file.
X!
X! Author:`09Tim Cook (timcc@viccol.edu.au)
X`7D
X
X`5BINHERIT ('SYS$LIBRARY:STARLET', 'VCDEFS', 'TAR'),
X   %INCLUDE 'TAR_VERSION.PAS'`5D
X
XMODULE extract ;
X
X   CONST
X      `7B When TAR extracts a record of length >= out_buffer_size, a wrap
X        occurs after out_buffer_size bytes.  This means records of length
X        out_buffer_size - 1 will be unaffected, and records of length
X        out_buffer_size will be immediately followed by an empty record.
X        This behaviour is necessary in order to reconstruct files that
X        have been wrapped by TAR `7D
X
X      out_buffer_size = 8192 ;
X
X   TYPE
X      UNIX_protection_type = `5BLONG`5D PACKED RECORD
X         others, group, owner : PACKED RECORD
X            execute, write, read : `5BBIT`5D boolean END END ;
X      out_buffer_type = PACKED ARRAY `5B1..out_buffer_size`5D OF char ;
X
X   VAR
X      out_fab : FAB$TYPE ;
X      out_nam : NAM$TYPE ;
X      out_xabrdt : XAB$TYPE ;
X      out_xabpro : XAB$TYPE ;
X      out_rab : RAB$TYPE ;
X      default_protection : lib_word_type ;  `7B from SYS$SETDFPROT `7D
X      output_buffer : out_buffer_type ;
X      output_result_spec : PACKED ARRAY `5B1..NAM$C_MAXRSS`5D OF char ;
X
X   VALUE
X      out_fab := zero ;
X      out_nam := zero ;
X      out_xabrdt := zero ;
X      out_xabpro := zero ;
X      out_rab := zero ;
X
X
X   PROCEDURE open_output_file (
X      VAR file_name : filespec_type ;
X      file_size : integer) ;
X
X      VAR
X         dir : medium_string ;
X         status, secondary_status, dir_status : sts_type ;
X
X      BEGIN
X         out_fab.FAB$B_BID := FAB$C_BID ;
X         out_fab.FAB$B_BLN := FAB$C_BLN ;
X         out_fab.FAB$B_RFM := FAB$C_VAR ; `7B Varying-length records `7D
X         out_fab.FAB$V_CR := true ;`09`7B Carriage-return RAT `7D
X         out_fab.FAB$V_PUT := true ;`09`7B PUT access `7D
X         out_fab.FAB$V_TEF := true ;`09`7B Truncate on $CLOSE `7D
X         out_fab.FAB$L_FNA := iaddress (file_name.body) ;
X         out_fab.FAB$B_FNS := (file_name.length)::lib_byte_type ;
X         IF file_size > 0 THEN
X            out_fab.FAB$L_ALQ := (file_size - 1) DIV VMS_block_size + 1 ;
X
X         out_fab.FAB$L_NAM := iaddress (out_nam) ;
X         out_nam.NAM$B_BID := NAM$C_BID ;
X         out_nam.NAM$B_BLN := NAM$C_BLN ;
X         out_nam.NAM$L_RSA := iaddress (output_result_spec) ;
X         out_nam.NAM$B_RSS := NAM$C_MAXRSS ;
X
X         status := $CREATE (out_fab) ;
X
X         IF status = RMS$_DNF THEN BEGIN`09`7B Directory not found `7D
X            dir := '' ;`09`09`09`09`7B %PASCAL-W if not done `7D
X            lib_parse (file_name, dir,,,, NAM__DEV, NAM__DIR) ;
X            dir_status := LIB$CREATE_DIR (dir) ;
X            IF success (dir_status) THEN BEGIN
X               LIB$SIGNAL (tar__createdir, 1, %STDESCR (dir)) ;
X               status := $CREATE (out_fab) END
X            ELSE
X               LIB$STOP (tar__errcredir, 1, %STDESCR (dir), dir_status) END
V ;
X
X         IF success (status) THEN BEGIN
X            out_rab.RAB$B_BID := RAB$C_BID ;
X            out_rab.RAB$B_BLN := RAB$C_BLN ;
X            out_rab.RAB$B_MBC := tar_multi_block_count ;
X               `7B Multi-block count; specifies how many blocks of a sequent
Vial
X                 file are transferred per disk access `7D
X            out_rab.RAB$L_FAB := iaddress (out_fab) ;
X            file_name := substr (output_result_spec, 1, out_nam.NAM$B_RSL) ;
X
X            status := $CONNECT (out_rab) ;
X
X            IF success (status) THEN BEGIN
X               out_rab.RAB$B_RAC := RAB$C_SEQ ;
X               out_rab.RAB$L_RBF := iaddress (output_buffer) END
X            ELSE
X               secondary_status := (out_rab.RAB$L_STV)::sts_type END
X
X         ELSE
X            secondary_status := (out_fab.FAB$L_STV)::sts_type ;
X
X         IF failure (status) THEN BEGIN
X            lib_parse (file_name, file_name) ;
X            LIB$STOP (tar__createrr, 1, %STDESCR (file_name), status,
X               secondary_status) END ;
X
X         END ;
X
X
X   PROCEDURE close_output_file (
X      no_records : integer ;
X      file_mtime : unsigned ;
X      file_mode : `5BUNSAFE`5D UNIX_protection_type) ;
X
X      VAR
X         created_filespec : medium_string ;
X         VMS_protection : file_protection_type ;
X
X      BEGIN
X         created_filespec :=
X            substr (output_result_spec, 1, out_nam.NAM$B_RSL) ;
X
X         out_fab.FAB$L_XAB := iaddress (out_xabrdt) ;
X
X         out_xabrdt.XAB$B_COD := XAB$C_RDT ;
X         out_xabrdt.XAB$B_BLN := XAB$C_RDTLEN ;
X         out_xabrdt.XAB$L_NXT := iaddress (out_xabpro) ;
X
X         out_xabrdt.XAB$Q_RDT := UNIX_to_VMS_time (file_mtime, delta_seconds
V) ;
X
X         out_xabpro.XAB$B_COD := XAB$C_PRO ;
X         out_xabpro.XAB$B_BLN := XAB$C_PROLEN ;
X         lib_sigiferr (LIB$GETJPI (JPI$_UIC,,, out_xabpro.XAB$L_UIC)) ;
X         VMS_protection := (default_protection)::file_protection_type ;
X
X   `7B Here is where the file protection is copied `7D
X         VMS_protection.world.noread := NOT file_mode.others.read ;
X         VMS_protection.world.noexecute := NOT file_mode.others.read ;
X         VMS_protection.world.nowrite := NOT file_mode.others.write ;
X
X         VMS_protection.group.noread := NOT file_mode.group.read ;
X         VMS_protection.group.noexecute := NOT file_mode.group.read ;
X         VMS_protection.group.nowrite := NOT file_mode.group.write ;
X
X         VMS_protection.owner.noread := NOT file_mode.owner.read ;
X         VMS_protection.owner.noexecute := NOT file_mode.owner.read ;
X         VMS_protection.owner.nowrite := NOT file_mode.owner.write ;
X         VMS_protection.owner.nodelete := NOT file_mode.owner.write ;
X
X         out_xabpro.XAB$W_PRO := (VMS_protection)::lib_word_type ;
X
X         IF failure ($CLOSE (out_fab)) THEN
X            LIB$STOP (tar__close, 1, %STDESCR (created_filespec),
X               out_fab.FAB$L_STS, out_fab.FAB$L_STV)
X         ELSE
X            LIB$SIGNAL (tar__created, 2, %STDESCR (created_filespec),
X               no_records) ;
X         END ;
X
X
X   `5BGLOBAL`5D PROCEDURE tar_extract (
X      VAR archive_filespec : `5BREADONLY`5D filespec_type ;
X      confirm : boolean) ;
X
X      VAR
X         header : boolean ;               `7B true if current tar_record is
V one `7D
X         no_records : integer ;           `7B no of tar records for curr fil
Ve `7D
X         file_spec : filespec_type ;
X         file_size : integer ;
X         file_mtime : unsigned ;
X         file_mode : file_mode_type ;
X         bytes_written : integer ;        `7B bytes written to curr out_file
V `7D
X         files_created, files_scanned : integer ;
X         tar_filespec, upcase_spec : filespec_type ;
X         more, verbose : boolean ;
X         file_scanned, warned_of_wrap : boolean ;
X         absolute : boolean ;
X         directory : boolean ;
X         link : boolean ;
X         link_spec : filespec_type ;
X         protection : unsigned ;          `7B UNIX style protection `7D
X
X
X      PROCEDURE extract_file (
X         VAR header_record : tar_record_type ;
X         file_spec : filespec_type ;
X         file_size : integer ;
X         file_mtime : unsigned ;
X         file_mode : file_mode_type ;
X         link : boolean := false ;
X         VAR link_spec : `5BREADONLY`5D filespec_type) ;
X
X         VAR
X            more : boolean ;
X            VMS_spec : filespec_type ;
X            absolute : boolean ;
X            output_file_open : `5BSTATIC`5D boolean := false ;
X
X
X         `5BCHECK(NONE)`5D PROCEDURE write_block (
X            VAR block : `5BREADONLY`5D tar_record_type ;
X            VAR bytes_written : integer ;
X            VAR no_records : integer) ;
X
X            VAR
X               i, status : integer ;
X               out_pointer : `5BSTATIC`5D lib_word_type := 0 ;
X               more : boolean ;
X
X            BEGIN
X               i := 0 ;
X               more := true ;
X               WHILE more DO BEGIN
X                  i := i + 1 ;
X                  IF i > record_size THEN more := false
X                  ELSE BEGIN
X                     bytes_written := bytes_written + 1 ;
X                     IF bytes_written = file_size THEN BEGIN    `7B eof `7D
X                        more := false ;
X                        IF block.data`5Bi`5D <> lf THEN BEGIN
X                           out_pointer := out_pointer + 1 ;
X                           output_buffer`5Bout_pointer`5D := block.data`5Bi`
V5D END ;
X                        out_rab.RAB$W_RSZ := out_pointer ;
X                        out_pointer := 0 ;
X                        status := $PUT (out_rab) ;
X                        IF failure (status) THEN
X                           LIB$STOP (tar__errwrite, 1, %STDESCR (VMS_spec),
X                              out_rab.RAB$L_STS, out_rab.RAB$L_STV) ;
X                        no_records := no_records + 1 END
X                     ELSE IF block.data`5Bi`5D = lf THEN BEGIN        `7B eo
Vln `7D
X                           out_rab.RAB$W_RSZ := out_pointer ;
X                           out_pointer := 0 ;
X                           status := $PUT (out_rab) ;
X                           IF failure (status) THEN
X                              LIB$STOP (tar__errwrite, 1, %STDESCR (VMS_spec
V),
X                                 out_rab.RAB$L_STS, out_rab.RAB$L_STV) ;
X                           no_records := no_records + 1 END
X                        ELSE BEGIN
X                           out_pointer := out_pointer + 1 ;
X                           output_buffer`5Bout_pointer`5D := block.data`5Bi`
V5D ;
X                           IF out_pointer = out_buffer_size THEN BEGIN `7B w
Vrap `7D
X                              out_rab.RAB$W_RSZ := out_pointer ;
X                              IF failure ($PUT (out_rab)) THEN
X                                 LIB$STOP (tar__errwrite, 1,
X                                    %STDESCR (VMS_spec), out_rab.RAB$L_STS,
X                                    out_rab.RAB$L_STV) ;
X                              no_records := no_records + 1 ;
X                              IF NOT warned_of_wrap THEN BEGIN
X                                 LIB$SIGNAL (tar__wrapped, 2,
X                                    %STDESCR (VMS_spec), out_buffer_size) ;
X                                 warned_of_wrap := true END ;
X                              out_pointer := 0 END END ;
X                     END ;
X                  END ;  `7B WHILE more `7D
X               END ;  `7B write_block `7D
X
X
X         BEGIN    `7B extract_file `7D
X            CASE archive`5E.linkflag OF
X               '1' :
X                  LIB$SIGNAL (tar__hardlink, 2,
X                     %STDESCR (file_spec), %STDESCR (link_spec)) ;
X               '2' :
X                  LIB$SIGNAL (tar__symlink, 2,
X                     %STDESCR (file_spec), %STDESCR (link_spec)) ;
X               OTHERWISE BEGIN   `7B normal file `7D
X                  VMS_spec := VMS_filespec (file_spec, absolute) ;
X                  no_records := 0 ;
X                  bytes_written := 0 ;
X                  open_output_file (VMS_spec, file_size) ;
X                  output_file_open := true ;
X                  more := file_size > 0 ;
X                  WHILE more DO BEGIN
X                     get (archive) ;
X                     write_block (archive`5E, bytes_written, no_records) ;
X                     IF bytes_written = file_size THEN
X                        more := false END ;
X                  close_output_file (no_records, file_mtime, file_mode) ;
X                  END END END ;
X
X
X      PROCEDURE make_directory (
X         file_spec : filespec_type ;
X         file_mode : file_mode_type) ;
X
X         VAR
X            temp_spec : medium_string ;
X            absolute : boolean ;
X            status : sts_type ;
X
X         BEGIN
X            temp_spec := VMS_filespec (file_spec + 'place.holder', absolute)
V ;
X            lib_parse (temp_spec, temp_spec,,,, NAM__DEV, NAM__DIR) ;
X            status := LIB$CREATE_DIR (temp_spec) ;
X            IF success (status) THEN
X               LIB$SIGNAL (tar__createdir, 1, %STDESCR (temp_spec))
X            ELSE
X               LIB$STOP (tar__errcredir, 1, %STDESCR (temp_spec), status) EN
VD ;
X
X
X      BEGIN    `7B extract `7D
X         IF cli_present (filespec_kt) THEN
X            collect_matches (match_node)
X         ELSE BEGIN
X            match_all := true ;
X            match_node := nil END ;
X         open_archive_input (archive_filespec) ;
X         full_archive_spec := find_file_spec (archive) ;
X         lib_sigiferr (SYS$SETDFPROT (, default_protection)) ;
X         files_created := 0 ;
X         files_scanned := 0 ;
X         header := true ;
X         more := true ;
X         WHILE more DO BEGIN
X            warned_of_wrap := false ;
X            file_scanned := false ;
+-+-+-+-+-+-+-+-  END  OF PART 4 +-+-+-+-+-+-+-+-