Posted to tcl by de at Fri Aug 24 11:32:09 GMT 2018view pretty

package require zipfile::mkzip 

# zipfile::mkzip::add_str_to_archive --
#
#        Add a string as a single file with string as content with
#        argument path to a zip archive. The zipchan channel should
#        already be open and binary. You may provide a comment for the
#        file The return value is the central directory record that
#        will need to be used when finalizing the zip archive.
#
# FIX ME: should  handle the current offset for non-seekable channels
#

proc ::zipfile::mkzip::add_str_to_archive {zipchan path data {comment ""}} {
    set mtime [timet_to_dos [clock seconds]]
    set utfpath [encoding convertto utf-8 $path]
    set utfcomment [encoding convertto utf-8 $comment]
    set flags [expr {(1<<11)}] ;# utf-8 comment and path
    set method 0               ;# store 0, deflate 8
    set attr 0                 ;# text or binary (default binary)
    set version 20             ;# minumum version req'd to extract
    set extra ""
    set crc 0
    set size 0
    set csize 0
    set seekable [expr {[tell $zipchan] != -1}]
    set attrex 0x81b60020  ;# 0o100666 (-rw-rw-rw-)
  
    set utfdata [encoding convertto utf-8 $data]
    set size [string length $utfdata]
  
    set offset [tell $zipchan]
    set local [binary format a4sssiiiiss PK\03\04 \
                   $version $flags $method $mtime $crc $csize $size \
                   [string length $utfpath] [string length $extra]]
    append local $utfpath $extra
    puts -nonewline $zipchan $local
  
    set crc [::zlib crc32 $utfdata]
    set cdata [::zlib deflate $utfdata]
    if {[string length $cdata] < $size} {
        set method 8
        set utfdata $cdata
    }
    set csize [string length $utfdata]
    puts -nonewline $zipchan $utfdata

    # update the header
    set local [binary format a4sssiiii PK\03\04 \
                   $version $flags $method $mtime $crc $csize $size]
    set current [tell $zipchan]
    seek $zipchan $offset
    puts -nonewline $zipchan $local
    seek $zipchan $current
  
    set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \
                 $version $flags $method $mtime $crc $csize $size \
                 [string length $utfpath] [string length $extra]\
                 [string length $utfcomment] 0 $attr $attrex $offset]
    append hdr $utfpath $extra $utfcomment
    return $hdr
}

# zipfile::mkzip::mkzipfromstr --
#
#        Create a zip archive in zf fd. If a file already exists
#        it will be overwritten by a new file. The option -runtime can
#        be used to specify a prefix file. For instance,
#        mkzipfromstr myzip -runtime unzipsfx.exe name1 string1 name/2 string2
#        will create a self-extracting zip archive from strings
#        string1 and string2 with the filenames name1 and name/2. The
#        -comment parameter specifies an optional comment for the
#        archive.
#
#        eg: mkzipfromstr my.zip name1 string1 name/2 string1
# 
proc ::zipfile::mkzip::mkzipfromstr {zf args} {
    array set opts {
        -zipkit 0 -runtime "" -comment ""
        -verbose 0 -callback ""
    }
    
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -verbose { set opts(-verbose) 1}
            -zipkit  { set opts(-zipkit) 1 }
            -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] }
            -runtime { set opts(-runtime) [pop args 1] }
            -callback {set opts(-callback) [pop args 1] }
            -- { pop args ; break }
            default {
                break
            }
        }
        pop args
    }

    setbinary $zf
    if {$opts(-runtime) ne ""} {
        set rt [::open $opts(-runtime) rb]
        setbinary $rt
        fcopy $rt $zf
        close $rt
    } elseif {$opts(-zipkit)} {
        set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n"
        append zkd "package require vfs::zip\n"
        append zkd "vfs::zip::Mount \[info script\] \[info script\]\n"
        append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} \{\n"
        append zkd "    source \[file join \[info script\] main.tcl\]\n"
        append zkd "\}\n"
        append zkd \x1A
        puts -nonewline $zf $zkd
    }

    set count 0
    set cd ""

    foreach {path data} $args {
        if {[string is true $opts(-verbose)]} {
            puts $path
        }
        if {$opts(-callback) ne ""} {
            {*}$opts(-callback) $path
        }
        append cd [add_str_to_archive $zf $path $data]
        incr count
    }
    set cdoffset [tell $zf]
    set endrec [binary format a4ssssiis PK\05\06 0 0 \
                    $count $count [string length $cd] $cdoffset\
                    [string length $opts(-comment)]]
    append endrec $opts(-comment)
    puts -nonewline $zf $cd
    puts -nonewline $zf $endrec
    close $zf

    return
}

# Example
# ::zipfile::mkzip::mkzipfromstr test.zip eins "Inhalt von eins" zwei "Und mit Umlauten: äöüß zwei" drei/eins "Schau mer mal"