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"