Script Library: untar.r

Script Library: 1240 scripts
untar.r

REBOL [
    title: "UnTar"
    file: %untar.r
    author: "Marco Antoniazzi"
    email: [luce80 AT libero DOT it]
    date: 09-03-2013
    version: 0.8.3
    Purpose: "Extracts tar archives."
    History: [
        0.0.1 [17-12-2012 "Started"]
        0.8.0 [19-12-2012 "Works"]
        0.8.3 [09-03-2013 "Extracts also directories"]
        0.8.4 [17-03-2013 "Fixed first bytes and prefix bugs"]
    ]
    library: [
        level: 'intermediate
        platform: 'all
        type: 'tool
        domain: [file-handling files compression]
        tested-under: [View 2.7.8.3.1]
        support: none
        license: 'public-domain
    ]
    notes: {This is only a minimal implementation.}
    Usage: {
        To only list archive contents:

            untar/list/no-extract %test.tar

        To extract archive contents to a specific directory:

            untar/to %test.tar %dir/
    }
]

ctx-untar: context [
    alphadigits: "0123456789ABCDEF"
    enbase: func [value [integer!] /base base-value [integer!] /local result num][
        if value = 0 [return "0"]
        base-value: any [base-value 16]
        result: copy ""
        while [value <> 0][
            num: mod value base-value
            insert result any [alphadigits/(num + 1) "0"]
            value: (value - num) / base-value
        ]
        result
    ]
    debase: func [value [any-string!] /base base-value [integer!] /local num char pos][
        base-value: any [base-value 16]
        num: 0
        foreach char value [
            if none? pos: find alphadigits char [break]
            num: num * base-value + (index? pos) - 1
        ]
        num
    ]
    from-octal: func [value][debase/base value 8]

    set 'untar func [[catch]
        "Extracts the files in a tar archive from a binary! or a file."
        value [file! url! binary!] "The archive"
        /to dest [file! url! block!] "The directory or a block where to put extracted files (default is current dir)"
        /list "Show name and size of extracted files"
        /no-extract "Do not extract files"
        /local
        archive current-dir data rounded-size dest-file
        ; tar header vars
        name mode uid gid size
        mtime checksum typeflag
        linkname magic version uname gname
        devmajor devminor prefix pad
        ][

        either any [file? value url? value] [
            if none? file: attempt [open/read/direct/binary value] [throw make error! "Unable to open source file"]
        ][
            file: value
        ]
        current-dir: what-dir
        if file? dest [
            if not dir? dest [print ["Unable to read" dest ". Using current dir"] dest: current-dir]
            change-dir dest
        ]

        if list [print ["Archive contents:" newline]]
        while [all [archive: copy/part file 512 0 <> first archive]][
            if binary? value [file: skip file 512] ; skip header
            parse/all archive [
                copy name 100 skip
                copy mode 8 skip
                copy uid 8 skip
                copy gid 8 skip
                copy size 12 skip
                copy mtime 12 skip
                copy checksum 8 skip
                copy typeflag 1 skip
                copy linkname 100 skip
                copy magic 6 skip
                copy version 2 skip
                copy uname 32 skip
                copy gname 32 skip
                copy devmajor 8 skip
                copy devminor 8 skip
                copy prefix 155 skip
                copy pad 12 skip
            ]
            size: from-octal size
            if list [print [name size "bytes"]]
            data: copy/part file rounded-size: round/ceiling/to size 512
            if binary? value [file: skip file rounded-size]
            name: trim/with name "^@"
            prefix: trim/with prefix "^@"
            ; only extract regular files and directories
            if all [any [#"5" = first typeflag #"/" = last name] not block? dest not no-extract] [make-dir to-rebol-file name]
            if all [any [#"0" = first typeflag #"^@" = first typeflag] not no-extract] [
                either block? dest [
                    insert tail dest copy/part data size
                ][
                    if prefix <> "" [append prefix "/"]
                    dest-file: to-rebol-file join prefix name
                    write/binary/part dest-file data size
                ]
            ]
        ]
        change-dir current-dir
        either block? dest [dest][exit]
    ]
    ;do 
    [
        untar %test.tar
        halt
    ]
]