From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 18-SEP-1989 10:26
To:	MRGATE::"ARISIA::EVERHART"
Subj:	VMS TAR v1.1   part 4 of 6

Received: From UCBVAX.BERKELEY.EDU by GIZMO.SRI.COM with TCP; Mon, 18 SEP 89 06:35:29 PDT
Received: by ucbvax.Berkeley.EDU (5.61/1.37)
	id AA29043; Mon, 18 Sep 89 06:24:56 -0700
Received: from USENET by ucbvax.Berkeley.EDU with netnews
	for info-vax@kl.sri.com (info-vax@kl.sri.com)
	(contact usenet@ucbvax.Berkeley.EDU if you have questions)
Date: 15 Sep 89 18:14:35 GMT
From: murtoa.cs.mu.oz.au!viccol!timcc@uunet.uu.net  (Tim Cook)
Organization: Computer Services, Victoria College, Melbourne
Subject: VMS TAR v1.1   part 4 of 6
Message-Id: <1964@csv.viccol.edu.au>
Sender: info-vax-request@kl.sri.com
To: info-vax@kl.sri.com

-+-+-+-+-+-+-+-+ START OF PART 4 -+-+-+-+-+-+-+-+
X      VAR header_record : `091READONLY`093 tar_record_type) : boolean ;
X
X      CONST
X         `123 A TAR checksum is computed with the checksum field temporarily
X           filled with spaces. `125
X         constant_part = size (header_record.chksum) * ord (space) ;
X
X      VAR
X         sum, header_sum : integer ;
X         upto : integer ;
X
X      BEGIN
X         IF header_record.chksum.fill_null = space THEN BEGIN `123 simple ch
Veck `125
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`091i`093) ;
X            FOR i := byte_offset (tar_record_type, linkflag)
X            TO tar_record_size DO
X               sum := sum + ord (header_record.data`091i`093) ;
X            readv (header_record.chksum.value, header_sum:oct) ;
X            is_valid_header := sum = header_sum END
X         ELSE
X            is_valid_header := false END ;
X
X
X   FUNCTION inspect_header (   `123 Computes and checks the header checksum
V `125
X      VAR header_record : `091READONLY`093 tar_record_type ;
X      VAR file_spec : VARYING `091n1`093 OF char ;
X      VAR file_size : integer ;
X      VAR file_mtime : unsigned ;
X      VAR file_mode : file_mode_type ;
X      VAR directory : boolean) : 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         IF is_valid_header (header_record) 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`09110`093 THEN
X               IF file_size = 0 THEN
X                  directory := true
X               ELSE
X                  bad_header (header_record)
X            ELSE
X               IF (file_spec`091file_spec.length`093 = slash)
X               AND (file_size = 0) THEN
X                  directory := true END
X         ELSE BEGIN
X            inspect_header := false ;
X            IF checksum (header_record) = 0 THEN      `123 TAR's EOF marker
V `125
X               eof_mark_found := true END ;
X
X         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      `123 Assume archive`094 contains header prior to next header `125
X
X         IF file_size = -1 THEN
X            readv (archive`094.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            `123 Don't look for any corresponding "dispose" calls ... `125
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`094.next := current_ptr ;
X
X            i := 1 ;
X            WHILE i <= filespec.length DO BEGIN
X               current_ptr`094.string`091i`093 := filespec`091i`093 ;
X               i := i + 1 END ;
X            current_ptr`094.string`091i`093 := null ;
X
X            current_ptr`094.literal := cli_present (literal_kt) ;
X            tmp_ptr := current_ptr END ;
X         current_ptr`094.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`094.literal THEN
X                  IF current_ptr`094.string`091cand_spec.length`093 = null T
VHEN BEGIN
X                     i := 1 ;
X                     match := true ;
X                     WHILE match AND (i < cand_spec.length) DO BEGIN
X                        match := current_ptr`094.string`091i`093 = cand_spec
V`091i`093 ;
X                        i := i + 1 END END
X                  ELSE
X               ELSE BEGIN
X                  match := SHELL$MATCH_WILD (cand_spec.body,
X                     current_ptr`094.string) ;
X                  IF match THEN BEGIN
X                     cand_slashes := 0 ;
X                     i := 1 ;
X                     WHILE cand_spec`091i`093 <> null DO BEGIN
X                        IF cand_spec`091i`093 = slash THEN
X                           cand_slashes := cand_slashes + 1 ;
X                        i := i + 1 END ;
X                     match_slashes := 0 ;
X                     i := 1 ;
X                     WHILE current_ptr`094.string`091i`093 <> null DO BEGIN
X                        IF current_ptr`094.string`091i`093 = 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`094.next END ;
X            match_filespec := match END END ;
X
X
X   `091EXTERNAL`093 PROCEDURE tar_list (
X      VAR archive_filespec : `091READONLY`093 filespec_type ;
X      full : boolean) ; external ;
X
X   `091EXTERNAL`093 PROCEDURE tar_extract (
X      VAR archive_filespec : `091READONLY`093 filespec_type ;
X      confirm : boolean) ; external ;
X
X   `091EXTERNAL`093 PROCEDURE tar_write (
X      VAR archive_filespec : `091READONLY`093 filespec_type ;
X      confirm : boolean ;
X      scan : boolean ;
X      map_mode : map_mode_type ;
X      appending : boolean := false) ; external ;
X
X   `091EXTERNAL`093 PROCEDURE tar_append (
X      VAR archive_filespec : `091READONLY`093 filespec_type ;
X      confirm : boolean ;
X      scan : boolean ;
X      map_mode : map_mode_type) ; 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`0911`093 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    `123 tar `125
X      establish (tar_handler) ;
X      delta_seconds := get_timezone ;`009`009`123 Read logical TAR_TIMEZONE
V `125
X
X      `123 Get archive name `125
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`0911`093 OF    `123 case selector must be an ordinal type
V `125
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) ;
X         'A' :
X            tar_append (archive_filespec, cli_present (confirm_kt),
X               cli_present (scan_kt), get_map_mode) ;
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 1349548980
$ create/nolog 'f'
X! The 105 in the following .FACILITY directive can be changed, but the
X! /PREFIX must be TAR__.
X
X.FACILITY`009TAR, 105 /PREFIX=TAR__
X
X.BASE 256
X.SEVERITY`009SUCCESS`009`009! 256 messages in this group
XCREATED`009`009<created !AS (!SL record!%S)> /FAO=2
XCREATEDIR`009<created directory !AS> /FAO=1
XWRITTEN`009`009<written !AS (!SL byte!%S)> /FAO=2
XAPPENDED`009<appended !AS (!SL byte!%S)> /FAO=2
XTOTCREAT`009<total of !SL file!%S created, !SL file!%S scanned> /FAO=2
XTOTWRITE`009<total of !SL file!%S written> /FAO=1
XTOTAPPEND`009<total of !SL file!%S appended> /FAO=1
X
X.BASE 512
X.SEVERITY`009INFORMATIONAL`009! 256 messages in this group
XEMPTY`009`009<file !AS empty, no output file created> /FAO=1
XHARDLINK`009<file !AS empty (hard link), no output file created> /FAO=1
XSOFTLINK`009<file !AS empty (soft link), no output file created> /FAO=1
X
X.BASE 768
X.SEVERITY`009WARNING`009`009! 256 messages in this group
XNOFILES`009`009<no files selected from !AS> /FAO=1
XWRAPPED`009`009<records in file !AS longer than !UL byte!%S have been wrappe
Vd> -
X`009`009   /FAO=1
XRECTOOLONG`009<record size of !UL too large for input buffer> /FAO=1
X
X.BASE 1024
X.SEVERITY`009ERROR`009`009! 256 messages in this group
XERRCREDIR`009<error creating directory !AS> /FAO=1
X
X.BASE 1280
X.SEVERITY`009FATAL
XBADHEADER`009<bad header record, dumped in file SYS$SCRATCH:HEADER.TAR>
XBADARCHIVE`009<!AS is not a TAR archive file> /FAO=1
XPARSE`009`009<error parsing !AS> /FAO=1
XOPENIN`009`009<error opening !AS for input> /FAO=1
XCLOSE`009`009<error closing !AS> /FAO=1
XCREATERR`009<error creating !AS> /FAO=1
X! Converted from PAS$_ERRDURGET
XERRREAD`009`009<error reading !+!+!AS> /FAO=3
XERRWRITE`009<error writing !AS> /FAO=1
XINVTIMZON`009<invalid timezone value "!AS"> /FAO=1
XINTERNERR`009<internal error, code !8XL, notify System Administrator> /FAO=1
$ CALL UNPACK TARMSG.MSG;1 689850316
$ create/nolog 'f'
X`091INHERIT ('SYS$LIBRARY:STARLET', 'VCDEFS', 'TAR'),
X   IDENT ('T1.1')`093
X
XMODULE extract ;
X
X   CONST
X      `123 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 `125
X
X      out_buffer_size = 8193 ;
X
X   TYPE
X      UNIX_protection_type = `091LONG`093 PACKED RECORD
X         others, group, owner : PACKED RECORD
X            execute, write, read : `091BIT`093 boolean END END ;
X      out_buffer_type = PACKED ARRAY `0911..out_buffer_size`093 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 ;  `123 from SYS$SETDFPROT `125
X      output_buffer : out_buffer_type ;
X      output_result_spec : PACKED ARRAY `0911..NAM$C_MAXRSS`093 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 ; `123 Varying-length records `125
X         out_fab.FAB$V_CR := true ;`009`123 Carriage-return RAT `125
X         out_fab.FAB$V_PUT := true ;`009`123 PUT access `125
X         out_fab.FAB$V_TEF := true ;`009`123 Truncate on $CLOSE `125
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`009`123 Directory not found `125
X            dir := '' ;`009`009`009`009`123 %PASCAL-W if not done `125
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               `123 Multi-block count; specifies how many blocks of a sequen
Vtial
X                 file are transferred per disk access `125
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 : `091UNSAFE`093 UNIX_protection_type) ;
X
X      VAR
X         created_filespec : medium_string ;
X         VMS_protection : file_protection_type ;
X         time_vec : lib_numtim_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   `123 Here is where the modification date is converted/copied `125
X         add_timezone (file_mtime) ;
X         break_up_UNIX_time (file_mtime, time_vec) ;
X         time_vec.year := time_vec.year + 1970 ;
X         time_vec.hundredth := 0 ;
X         lib_sigiferr (LIB$CVT_VECTIM (time_vec, out_xabrdt.XAB$Q_RDT)) ;
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   `123 Here is where the file protection is copied `125
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   `091GLOBAL`093 PROCEDURE tar_extract (
X      VAR archive_filespec : `091READONLY`093 filespec_type ;
X      confirm : boolean) ;
X
X      VAR
X         header : boolean ;               `123 true if current tar_record is
V one `125
X         no_records : integer ;           `123 no of tar records for curr fi
Vle `125
X         file_spec : filespec_type ;
X         file_size : integer ;
X         file_mtime : unsigned ;
X         file_mode : file_mode_type ;
X         bytes_written : integer ;        `123 bytes written to curr out_fil
Ve `125
X         files_created, files_scanned : integer ;
X         tar_filespec, upcase_spec : filespec_type ;
X         more, verbose : boolean ;
X         file_extracted, warned_of_wrap : boolean ;
X         absolute : boolean ;
X         directory : boolean ;
X         protection : unsigned ;          `123 UNIX style protection `125
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
X         VAR
X            more : boolean ;
X            VMS_spec : filespec_type ;
X            absolute : boolean ;
X
X
X         `091CHECK(NONE)`093 PROCEDURE write_block (
X            VAR block : `091READONLY`093 tar_record_type ;
X            VAR bytes_written : integer ;
X            VAR no_records : integer) ;
X
X            VAR
X               i, status : integer ;
X               out_pointer : `091STATIC`093 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    `123 eof `12
V5
X                        more := false ;
X                        IF block.data`091i`093 <> lf THEN BEGIN
X                           out_pointer := out_pointer + 1 ;
X                           output_buffer`091out_pointer`093 := block.data`09
V1i`093 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`091i`093 = lf THEN BEGIN        `123
V eoln `125
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`091out_pointer`093 := block.data`09
V1i`093 ;
X                           IF out_pointer = out_buffer_size THEN BEGIN `123
V wrap `125
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 ;  `123 WHILE more `125
X               END ;  `123 write_block `125
X
X
X         BEGIN    `123 extract_file `125
X            IF file_size = 0 THEN BEGIN
X               CASE archive`094.linkflag OF
X                  '1' :
X                     LIB$SIGNAL (tar__hardlink, 1,
X                        %STDESCR (file_spec)) ;
X                  '2' :
X                     LIB$SIGNAL (tar__softlink, 1,
X                        %STDESCR (file_spec)) ;
X                  OTHERWISE BEGIN
X                     VMS_spec := VMS_filespec (file_spec, absolute) ;
X                     open_output_file (VMS_spec, file_size) ;
X                     no_records := 0 END ;
X                  END END
X            ELSE BEGIN`009`009`123 this is done after each header `125
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               more := true ;
X               WHILE more DO BEGIN
X                  get (archive) ;
X                  write_block (archive`094, bytes_written, no_records) ;
X                  IF bytes_written = file_size THEN
X                     more := false END END ;
X            close_output_file (no_records, file_mtime, file_mode) 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    `123 extract `125
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_extracted := false ;
X            IF inspect_header (archive`094, file_spec, file_size, file_mtime
V,
X                  file_mode, directory) THEN BEGIN
X               files_scanned := files_scanned + 1 ;
X               IF match_filespec (file_spec, match_node) THEN
X                  IF confirm_operation (option, file_spec,
X                        (NOT confirm) OR directory, set_this_false, more)
X                  THEN BEGIN
X                     IF directory THEN
X                        IF NOT confirm THEN
X                           make_directory (file_spec, file_mode)
X                        ELSE  `123 forget it `125
+-+-+-+-+-+-+-+-  END  OF PART 4 +-+-+-+-+-+-+-+-

