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

  1.  
  2. package require zipfile::mkzip
  3.  
  4. # zipfile::mkzip::add_str_to_archive --
  5. #
  6. # Add a string as a single file with string as content with
  7. # argument path to a zip archive. The zipchan channel should
  8. # already be open and binary. You may provide a comment for the
  9. # file The return value is the central directory record that
  10. # will need to be used when finalizing the zip archive.
  11. #
  12. # FIX ME: should handle the current offset for non-seekable channels
  13. #
  14.  
  15. proc ::zipfile::mkzip::add_str_to_archive {zipchan path data {comment ""}} {
  16. set mtime [timet_to_dos [clock seconds]]
  17. set utfpath [encoding convertto utf-8 $path]
  18. set utfcomment [encoding convertto utf-8 $comment]
  19. set flags [expr {(1<<11)}] ;# utf-8 comment and path
  20. set method 0 ;# store 0, deflate 8
  21. set attr 0 ;# text or binary (default binary)
  22. set version 20 ;# minumum version req'd to extract
  23. set extra ""
  24. set crc 0
  25. set size 0
  26. set csize 0
  27. set seekable [expr {[tell $zipchan] != -1}]
  28. set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-)
  29.  
  30. set utfdata [encoding convertto utf-8 $data]
  31. set size [string length $utfdata]
  32.  
  33. set offset [tell $zipchan]
  34. set local [binary format a4sssiiiiss PK\03\04 \
  35. $version $flags $method $mtime $crc $csize $size \
  36. [string length $utfpath] [string length $extra]]
  37. append local $utfpath $extra
  38. puts -nonewline $zipchan $local
  39.  
  40. set crc [::zlib crc32 $utfdata]
  41. set cdata [::zlib deflate $utfdata]
  42. if {[string length $cdata] < $size} {
  43. set method 8
  44. set utfdata $cdata
  45. }
  46. set csize [string length $utfdata]
  47. puts -nonewline $zipchan $utfdata
  48.  
  49. # update the header
  50. set local [binary format a4sssiiii PK\03\04 \
  51. $version $flags $method $mtime $crc $csize $size]
  52. set current [tell $zipchan]
  53. seek $zipchan $offset
  54. puts -nonewline $zipchan $local
  55. seek $zipchan $current
  56.  
  57. set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \
  58. $version $flags $method $mtime $crc $csize $size \
  59. [string length $utfpath] [string length $extra]\
  60. [string length $utfcomment] 0 $attr $attrex $offset]
  61. append hdr $utfpath $extra $utfcomment
  62. return $hdr
  63. }
  64.  
  65. # zipfile::mkzip::mkzipfromstr --
  66. #
  67. # Create a zip archive in zf fd. If a file already exists
  68. # it will be overwritten by a new file. The option -runtime can
  69. # be used to specify a prefix file. For instance,
  70. # mkzipfromstr myzip -runtime unzipsfx.exe name1 string1 name/2 string2
  71. # will create a self-extracting zip archive from strings
  72. # string1 and string2 with the filenames name1 and name/2. The
  73. # -comment parameter specifies an optional comment for the
  74. # archive.
  75. #
  76. # eg: mkzipfromstr my.zip name1 string1 name/2 string1
  77. #
  78. proc ::zipfile::mkzip::mkzipfromstr {zf args} {
  79. array set opts {
  80. -zipkit 0 -runtime "" -comment ""
  81. -verbose 0 -callback ""
  82. }
  83.  
  84. while {[string match -* [set option [lindex $args 0]]]} {
  85. switch -exact -- $option {
  86. -verbose { set opts(-verbose) 1}
  87. -zipkit { set opts(-zipkit) 1 }
  88. -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] }
  89. -runtime { set opts(-runtime) [pop args 1] }
  90. -callback {set opts(-callback) [pop args 1] }
  91. -- { pop args ; break }
  92. default {
  93. break
  94. }
  95. }
  96. pop args
  97. }
  98.  
  99. setbinary $zf
  100. if {$opts(-runtime) ne ""} {
  101. set rt [::open $opts(-runtime) rb]
  102. setbinary $rt
  103. fcopy $rt $zf
  104. close $rt
  105. } elseif {$opts(-zipkit)} {
  106. set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n"
  107. append zkd "package require vfs::zip\n"
  108. append zkd "vfs::zip::Mount \[info script\] \[info script\]\n"
  109. append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} \{\n"
  110. append zkd " source \[file join \[info script\] main.tcl\]\n"
  111. append zkd "\}\n"
  112. append zkd \x1A
  113. puts -nonewline $zf $zkd
  114. }
  115.  
  116. set count 0
  117. set cd ""
  118.  
  119. foreach {path data} $args {
  120. if {[string is true $opts(-verbose)]} {
  121. puts $path
  122. }
  123. if {$opts(-callback) ne ""} {
  124. {*}$opts(-callback) $path
  125. }
  126. append cd [add_str_to_archive $zf $path $data]
  127. incr count
  128. }
  129. set cdoffset [tell $zf]
  130. set endrec [binary format a4ssssiis PK\05\06 0 0 \
  131. $count $count [string length $cd] $cdoffset\
  132. [string length $opts(-comment)]]
  133. append endrec $opts(-comment)
  134. puts -nonewline $zf $cd
  135. puts -nonewline $zf $endrec
  136. close $zf
  137.  
  138. return
  139. }
  140.  
  141. # Example
  142. # ::zipfile::mkzip::mkzipfromstr test.zip eins "Inhalt von eins" zwei "Und mit Umlauten: äöüß zwei" drei/eins "Schau mer mal"
  143.