<commit_before>! Copyright (C) 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays combinators io io.backend
io.directories io.encodings.binary io.files io.files.links
io.pathnames io.streams.byte-array io.streams.string kernel
math math.parser namespaces sequences strings summary
typed ;
IN: tar

CONSTANT: zero-checksum 256
CONSTANT: block-size 512

SYMBOL: to-link

: save-link ( link -- )
    to-link get push ;

TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;

ERROR: checksum-error header ;

: trim-string ( seq -- newseq ) [ "\0 " member? ] trim-tail ;

: read-c-string ( n -- str )
    read [ zero? ] trim-tail "" like ;

: read-tar-header ( -- tar-header )
    tar-header new
        100 read-c-string >>name
        8 read-c-string trim-string oct> >>mode
        8 read-c-string trim-string oct> >>uid
        8 read-c-string trim-string oct> >>gid
        12 read-c-string trim-string oct> >>size
        12 read-c-string trim-string oct> >>mtime
        8 read-c-string trim-string oct> >>checksum
        read1 >>typeflag
        100 read-c-string >>linkname
        6 read >>magic
        2 read >>version
        32 read-c-string >>uname
        32 read-c-string >>gname
        8 read trim-string oct> >>devmajor
        8 read trim-string oct> >>devminor
        155 read-c-string >>prefix ;

TYPED: checksum-header ( seq: byte-array -- n )
    148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] bi@ + 256 + >fixnum ;

: read-data-blocks ( tar-header -- )
    dup size>> 0 > [
        block-size read [
            over size>> dup block-size <= [
                head write drop
            ] [
                drop write
                [ block-size - ] change-size
                read-data-blocks
            ] if
        ] [
            drop
        ] if*
    ] [
        drop
    ] if ;

: parse-tar-header ( seq -- obj )
    dup checksum-header dup zero-checksum = [
        2drop
        tar-header new
            0 >>size
            0 >>checksum
    ] [
        [
            binary [ read-tar-header ] with-byte-reader
            dup checksum>>
        ] dip = [ checksum-error ] unless
    ] if ;

ERROR: unknown-typeflag ch ;

M: unknown-typeflag summary ( obj -- str )
    ch>> [ "Unknown typeflag: " ] dip prefix ;

: read/write-blocks ( tar-header path -- )
    binary [ read-data-blocks ] with-file-writer ;

: prepend-current-directory ( path -- path' )
    current-directory get prepend-path ;

! Normal file
: typeflag-0 ( header -- )
    dup name>> prepend-current-directory read/write-blocks ;

TUPLE: hard-link linkname name ;
C: <hard-link> hard-link

TUPLE: symbolic-link linkname name ;
C: <symbolic-link> symbolic-link

! Hard link, don't call normalize-path
: typeflag-1 ( header -- )
    [ linkname>> ] [ name>> ] bi <hard-link> save-link ;

! Symlink, don't call normalize-path
: typeflag-2 ( header -- )
    [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;

! character special<commit_msg>tar: cleanup stack effects, make read-data-blocks recursive.<commit_after>! Copyright (C) 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays combinators io io.backend
io.directories io.encodings.binary io.files io.files.links
io.pathnames io.streams.byte-array io.streams.string kernel
math math.parser namespaces sequences strings summary
typed ;
IN: tar

CONSTANT: zero-checksum 256
CONSTANT: block-size 512

SYMBOL: to-link

: save-link ( link -- )
    to-link get push ;

TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;

ERROR: checksum-error header ;

: trim-string ( seq -- newseq ) [ "\0 " member? ] trim-tail ;

: read-c-string ( n -- str )
    read [ zero? ] trim-tail "" like ;

: read-tar-header ( -- header )
    tar-header new
        100 read-c-string >>name
        8 read-c-string trim-string oct> >>mode
        8 read-c-string trim-string oct> >>uid
        8 read-c-string trim-string oct> >>gid
        12 read-c-string trim-string oct> >>size
        12 read-c-string trim-string oct> >>mtime
        8 read-c-string trim-string oct> >>checksum
        read1 >>typeflag
        100 read-c-string >>linkname
        6 read >>magic
        2 read >>version
        32 read-c-string >>uname
        32 read-c-string >>gname
        8 read trim-string oct> >>devmajor
        8 read trim-string oct> >>devminor
        155 read-c-string >>prefix ;

TYPED: checksum-header ( seq: byte-array -- n )
    148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] bi@ + 256 + >fixnum ;

: read-data-blocks ( header -- )
    dup size>> 0 > [
        block-size read [
            over size>> dup block-size <= [
                head write drop
            ] [
                drop write
                [ block-size - ] change-size
                read-data-blocks
            ] if
        ] [
            drop
        ] if*
    ] [
        drop
    ] if ; inline recursive

: parse-tar-header ( seq -- header )
    dup checksum-header dup zero-checksum = [
        2drop
        tar-header new
            0 >>size
            0 >>checksum
    ] [
        [
            binary [ read-tar-header ] with-byte-reader
            dup checksum>>
        ] dip = [ checksum-error ] unless
    ] if ;

ERROR: unknown-typeflag ch ;

M: unknown-typeflag summary
    ch>> [ "Unknown typeflag: " ] dip prefix ;

: read/write-blocks ( header path -- )
    binary [ read-data-blocks ] with-file-writer ;

: prepend-current-directory ( path -- path' )
    current-directory get prepend-path ;

! Normal file
: typeflag-0 ( header -- )
    dup name>> prepend-current-directory read/write-blocks ;

TUPLE: hard-link linkname name ;
C: <hard-link> hard-link

TUPLE: symbolic-link linkname name ;
C: <symbolic-link> symbolic-link

! Hard link, don't call normalize-path
: typeflag-1 ( header -- )
    [ linkname>> ] [ name>> ] bi <hard-link> save-link ;

! Symlink, don't call normalize-path
: typeflag-2 ( header -- )
    [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;

! character special
{'fraction_non_alphanumeric': 0.12107478148268049, 'fraction_numerical': 0.016833926837164132, 'mean_word_length': 2.0987963891675023, 'pattern_counts': {'":': 0, '<': 15, '<?xml version=': 0, '>': 141, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5483088', 'n_tokens_mistral': 2012, 'n_tokens_neox': 1929, 'n_words': 565}