├── .depend ├── .gitignore ├── Changes ├── LICENSE ├── META-camlzip ├── META-zip ├── Makefile ├── README.md ├── camlzip.opam ├── gzip.ml ├── gzip.mli ├── test ├── Makefile ├── bigfiles.run ├── manyfiles.run ├── minigzip.ml ├── minigzip.run ├── minizip.ml ├── minizip.run ├── testzlib.ml └── testzlib.run ├── zip.ml ├── zip.mli ├── zlib.ml ├── zlib.mli └── zlibstubs.c /.depend: -------------------------------------------------------------------------------- 1 | zlibstubs.o: zlibstubs.c 2 | gzip.cmo: zlib.cmi gzip.cmi 3 | gzip.cmx: zlib.cmx gzip.cmi 4 | zip.cmo: zlib.cmi zip.cmi 5 | zip.cmx: zlib.cmx zip.cmi 6 | zlib.cmo: zlib.cmi 7 | zlib.cmx: zlib.cmi 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.a 2 | *.cma 3 | *.cmi 4 | *.cmo 5 | *.cmx 6 | *.cmxs 7 | *.cmxa 8 | *.o 9 | *.so 10 | *.cmt 11 | *.cmti 12 | test/minigzip 13 | test/minizip 14 | test/testzlib 15 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Release 1.13: 2 | - #44: tolerate ZIP entries that are marked "deflated" but have size 0 3 | [Antoine Provot] 4 | - #46: provide `Zip.open_update` to add entries to an existing ZIP file 5 | - #47: in `Zlib.inflate`, detect and fail on truncated input instead of looping 6 | - #48: under Windows, store file names in ZIP entries using forward slashes `/` 7 | instead of backslashes `\` 8 | 9 | Release 1.12: 10 | - #35, #43: add full support for ZIP64 archives [Jules Villard and Xavier Leroy] 11 | - #41, #42: fix memory leak when a `Zlib.stream` is finalized and 12 | `Zlib.deflate_end` / `Zlib.inflate_end` was not called before 13 | 14 | Release 1.11: 15 | - `Zip.add_entry_generator ~level:0` was missing a CRC update 16 | - #28: fix build on platforms with no shared libs 17 | - #33: update META files to use plugin convention 18 | - Use `Stdlib.xxx` instead of `Pervasives.xxx`. OCaml >= 4.07 is required. 19 | - `make all` automatically builds in native-code if supported 20 | - Added local .opam file 21 | - Updated tests and added automatic test harness 22 | - Generate and install .mli, .cmt, and .cmti files 23 | 24 | Release 1.10: 25 | - #25: Fix Gzip.flush_continue [James Owen] 26 | - Improve compatibility with OCaml 4.09 27 | 28 | Release 1.09: 29 | - #22: Add a Gzip.flush_continue function that allows the user to 30 | flush the contents of the zip buffer all the way to disk but then 31 | continue writing to the zipped channel [James Owen] 32 | 33 | Release 1.08: 34 | - ocamlfind is now mandatory as a consequence of #4 35 | - #4: use ocamlfind and $(EXT_...) configuration variables for better 36 | cross-platform support in Makefile [user 'whitequark'] 37 | - Improve Mingw support in Makefile (install .dll files) [Bertrand Jeannet] 38 | - #5: make sure 'zip' and 'camlzip' packages can be used both in the 39 | same executable [Rudi Grinberg] 40 | - #6: Z_BUF_ERROR is not a fatal error, just a transient condition 41 | [Tuukka Korhonen] 42 | - #13: fix memory leak in Zlib.compress_direct [Alain Frisch] 43 | - #14: add Zlib.deflate_string and Zlib.inflate_string, using immutable 44 | strings as input buffers instead of mutable bytes [Vincent Balat] 45 | - #16: assertion failure when reading ZIP files with 2^16 entries or more 46 | [Einar Lielmanis] 47 | - #18: in Zip.open_in, properly close channels in case of error 48 | [Daniel Weil] 49 | 50 | Release 1.07: 51 | - Allocate Zlib data structures outside the OCaml heap for compatibility 52 | with recent versions of Zlib 53 | (Github issue #1, pull request #2, report and fix by Einar Lielmanis). 54 | - Don't pass -L and -I options to the C compiler unless necessary. 55 | - Compile and install the shared library zip.cmxs. 56 | (Contributed by E. Millon.) 57 | - ocamlfind: install under 'zip' and 'camlzip' package names. 58 | (This is what the OPAM package does.) 59 | 60 | Release 1.06: 61 | - Switch to "safe string" mode. Some API functions that use to take strings 62 | now take byte sequences instead. OCaml 4.02 or up is required. 63 | - Update for OCaml 4.03. 64 | - Avoid Zlib error when calling Gzip.output with length = 0. 65 | - Improve support for ZIP files / ZIP file members greater than 2 Gbytes. 66 | 67 | Release 1.05: 68 | - Added support for findlib (Contributed by E. Friendly) 69 | 70 | Release 1.04: 71 | - Added function Zip.add_entry_generator. (Contributed by A. Frisch.) 72 | - The "level" optional argument was sometimes not honored; fixed. 73 | - Relicensed under LGPL 2.1 or above, with Caml's special exception 74 | for static linking. 75 | 76 | Release 1.03: 77 | - Fixed bug in Zlib.uncompress that could cause it to loop infinitely. 78 | - Documentation comments in .mli files converted to ocamldoc format. 79 | 80 | Release 1.02: 81 | - 64-bit incompatibility fixed. 82 | - Better support for large ZIP files (> 2 Gb). 83 | - Added Caml's special exception for static linking to the license. 84 | 85 | Release 1.01: 86 | - Use ocamlmklib to create library and possibly DLL (for OCaml 3.04 and up). 87 | 88 | Release 1.00: 89 | - First public release 90 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This Library is distributed under the terms of the GNU Lesser General 2 | Public License (LGPL) version 2.1 or above (included below). 3 | 4 | As a special exception to the GNU Lesser General Public License, you 5 | may link, statically or dynamically, a "work that uses the Library" 6 | with a publicly distributed version of the Library to produce an 7 | executable file containing portions of the Library, and distribute 8 | that executable file under terms of your choice, without any of the 9 | additional requirements listed in clause 6 of the GNU Lesser General 10 | Public License. By "a publicly distributed version of the Library", 11 | we mean either the unmodified Library as distributed by INRIA, or a 12 | modified version of the Library that is distributed under the 13 | conditions defined in clause 3 of the GNU Lesser General Public 14 | License. This exception does not however invalidate any other reasons 15 | why the executable file might be covered by the GNU Lesser General 16 | Public License. 17 | 18 | ---------------------------------------------------------------------- 19 | 20 | GNU LESSER GENERAL PUBLIC LICENSE 21 | Version 2.1, February 1999 22 | 23 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 24 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 25 | Everyone is permitted to copy and distribute verbatim copies 26 | of this license document, but changing it is not allowed. 27 | 28 | [This is the first released version of the Lesser GPL. It also counts 29 | as the successor of the GNU Library Public License, version 2, hence 30 | the version number 2.1.] 31 | 32 | Preamble 33 | 34 | The licenses for most software are designed to take away your 35 | freedom to share and change it. By contrast, the GNU General Public 36 | Licenses are intended to guarantee your freedom to share and change 37 | free software--to make sure the software is free for all its users. 38 | 39 | This license, the Lesser General Public License, applies to some 40 | specially designated software packages--typically libraries--of the 41 | Free Software Foundation and other authors who decide to use it. You 42 | can use it too, but we suggest you first think carefully about whether 43 | this license or the ordinary General Public License is the better 44 | strategy to use in any particular case, based on the explanations below. 45 | 46 | When we speak of free software, we are referring to freedom of use, 47 | not price. Our General Public Licenses are designed to make sure that 48 | you have the freedom to distribute copies of free software (and charge 49 | for this service if you wish); that you receive source code or can get 50 | it if you want it; that you can change the software and use pieces of 51 | it in new free programs; and that you are informed that you can do 52 | these things. 53 | 54 | To protect your rights, we need to make restrictions that forbid 55 | distributors to deny you these rights or to ask you to surrender these 56 | rights. These restrictions translate to certain responsibilities for 57 | you if you distribute copies of the library or if you modify it. 58 | 59 | For example, if you distribute copies of the library, whether gratis 60 | or for a fee, you must give the recipients all the rights that we gave 61 | you. You must make sure that they, too, receive or can get the source 62 | code. If you link other code with the library, you must provide 63 | complete object files to the recipients, so that they can relink them 64 | with the library after making changes to the library and recompiling 65 | it. And you must show them these terms so they know their rights. 66 | 67 | We protect your rights with a two-step method: (1) we copyright the 68 | library, and (2) we offer you this license, which gives you legal 69 | permission to copy, distribute and/or modify the library. 70 | 71 | To protect each distributor, we want to make it very clear that 72 | there is no warranty for the free library. Also, if the library is 73 | modified by someone else and passed on, the recipients should know 74 | that what they have is not the original version, so that the original 75 | author's reputation will not be affected by problems that might be 76 | introduced by others. 77 | 78 | Finally, software patents pose a constant threat to the existence of 79 | any free program. We wish to make sure that a company cannot 80 | effectively restrict the users of a free program by obtaining a 81 | restrictive license from a patent holder. Therefore, we insist that 82 | any patent license obtained for a version of the library must be 83 | consistent with the full freedom of use specified in this license. 84 | 85 | Most GNU software, including some libraries, is covered by the 86 | ordinary GNU General Public License. This license, the GNU Lesser 87 | General Public License, applies to certain designated libraries, and 88 | is quite different from the ordinary General Public License. We use 89 | this license for certain libraries in order to permit linking those 90 | libraries into non-free programs. 91 | 92 | When a program is linked with a library, whether statically or using 93 | a shared library, the combination of the two is legally speaking a 94 | combined work, a derivative of the original library. The ordinary 95 | General Public License therefore permits such linking only if the 96 | entire combination fits its criteria of freedom. The Lesser General 97 | Public License permits more lax criteria for linking other code with 98 | the library. 99 | 100 | We call this license the "Lesser" General Public License because it 101 | does Less to protect the user's freedom than the ordinary General 102 | Public License. It also provides other free software developers Less 103 | of an advantage over competing non-free programs. These disadvantages 104 | are the reason we use the ordinary General Public License for many 105 | libraries. However, the Lesser license provides advantages in certain 106 | special circumstances. 107 | 108 | For example, on rare occasions, there may be a special need to 109 | encourage the widest possible use of a certain library, so that it becomes 110 | a de-facto standard. To achieve this, non-free programs must be 111 | allowed to use the library. A more frequent case is that a free 112 | library does the same job as widely used non-free libraries. In this 113 | case, there is little to gain by limiting the free library to free 114 | software only, so we use the Lesser General Public License. 115 | 116 | In other cases, permission to use a particular library in non-free 117 | programs enables a greater number of people to use a large body of 118 | free software. For example, permission to use the GNU C Library in 119 | non-free programs enables many more people to use the whole GNU 120 | operating system, as well as its variant, the GNU/Linux operating 121 | system. 122 | 123 | Although the Lesser General Public License is Less protective of the 124 | users' freedom, it does ensure that the user of a program that is 125 | linked with the Library has the freedom and the wherewithal to run 126 | that program using a modified version of the Library. 127 | 128 | The precise terms and conditions for copying, distribution and 129 | modification follow. Pay close attention to the difference between a 130 | "work based on the library" and a "work that uses the library". The 131 | former contains code derived from the library, whereas the latter must 132 | be combined with the library in order to run. 133 | 134 | GNU LESSER GENERAL PUBLIC LICENSE 135 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 136 | 137 | 0. This License Agreement applies to any software library or other 138 | program which contains a notice placed by the copyright holder or 139 | other authorized party saying it may be distributed under the terms of 140 | this Lesser General Public License (also called "this License"). 141 | Each licensee is addressed as "you". 142 | 143 | A "library" means a collection of software functions and/or data 144 | prepared so as to be conveniently linked with application programs 145 | (which use some of those functions and data) to form executables. 146 | 147 | The "Library", below, refers to any such software library or work 148 | which has been distributed under these terms. A "work based on the 149 | Library" means either the Library or any derivative work under 150 | copyright law: that is to say, a work containing the Library or a 151 | portion of it, either verbatim or with modifications and/or translated 152 | straightforwardly into another language. (Hereinafter, translation is 153 | included without limitation in the term "modification".) 154 | 155 | "Source code" for a work means the preferred form of the work for 156 | making modifications to it. For a library, complete source code means 157 | all the source code for all modules it contains, plus any associated 158 | interface definition files, plus the scripts used to control compilation 159 | and installation of the library. 160 | 161 | Activities other than copying, distribution and modification are not 162 | covered by this License; they are outside its scope. The act of 163 | running a program using the Library is not restricted, and output from 164 | such a program is covered only if its contents constitute a work based 165 | on the Library (independent of the use of the Library in a tool for 166 | writing it). Whether that is true depends on what the Library does 167 | and what the program that uses the Library does. 168 | 169 | 1. You may copy and distribute verbatim copies of the Library's 170 | complete source code as you receive it, in any medium, provided that 171 | you conspicuously and appropriately publish on each copy an 172 | appropriate copyright notice and disclaimer of warranty; keep intact 173 | all the notices that refer to this License and to the absence of any 174 | warranty; and distribute a copy of this License along with the 175 | Library. 176 | 177 | You may charge a fee for the physical act of transferring a copy, 178 | and you may at your option offer warranty protection in exchange for a 179 | fee. 180 | 181 | 2. You may modify your copy or copies of the Library or any portion 182 | of it, thus forming a work based on the Library, and copy and 183 | distribute such modifications or work under the terms of Section 1 184 | above, provided that you also meet all of these conditions: 185 | 186 | a) The modified work must itself be a software library. 187 | 188 | b) You must cause the files modified to carry prominent notices 189 | stating that you changed the files and the date of any change. 190 | 191 | c) You must cause the whole of the work to be licensed at no 192 | charge to all third parties under the terms of this License. 193 | 194 | d) If a facility in the modified Library refers to a function or a 195 | table of data to be supplied by an application program that uses 196 | the facility, other than as an argument passed when the facility 197 | is invoked, then you must make a good faith effort to ensure that, 198 | in the event an application does not supply such function or 199 | table, the facility still operates, and performs whatever part of 200 | its purpose remains meaningful. 201 | 202 | (For example, a function in a library to compute square roots has 203 | a purpose that is entirely well-defined independent of the 204 | application. Therefore, Subsection 2d requires that any 205 | application-supplied function or table used by this function must 206 | be optional: if the application does not supply it, the square 207 | root function must still compute square roots.) 208 | 209 | These requirements apply to the modified work as a whole. If 210 | identifiable sections of that work are not derived from the Library, 211 | and can be reasonably considered independent and separate works in 212 | themselves, then this License, and its terms, do not apply to those 213 | sections when you distribute them as separate works. But when you 214 | distribute the same sections as part of a whole which is a work based 215 | on the Library, the distribution of the whole must be on the terms of 216 | this License, whose permissions for other licensees extend to the 217 | entire whole, and thus to each and every part regardless of who wrote 218 | it. 219 | 220 | Thus, it is not the intent of this section to claim rights or contest 221 | your rights to work written entirely by you; rather, the intent is to 222 | exercise the right to control the distribution of derivative or 223 | collective works based on the Library. 224 | 225 | In addition, mere aggregation of another work not based on the Library 226 | with the Library (or with a work based on the Library) on a volume of 227 | a storage or distribution medium does not bring the other work under 228 | the scope of this License. 229 | 230 | 3. You may opt to apply the terms of the ordinary GNU General Public 231 | License instead of this License to a given copy of the Library. To do 232 | this, you must alter all the notices that refer to this License, so 233 | that they refer to the ordinary GNU General Public License, version 2, 234 | instead of to this License. (If a newer version than version 2 of the 235 | ordinary GNU General Public License has appeared, then you can specify 236 | that version instead if you wish.) Do not make any other change in 237 | these notices. 238 | 239 | Once this change is made in a given copy, it is irreversible for 240 | that copy, so the ordinary GNU General Public License applies to all 241 | subsequent copies and derivative works made from that copy. 242 | 243 | This option is useful when you wish to copy part of the code of 244 | the Library into a program that is not a library. 245 | 246 | 4. You may copy and distribute the Library (or a portion or 247 | derivative of it, under Section 2) in object code or executable form 248 | under the terms of Sections 1 and 2 above provided that you accompany 249 | it with the complete corresponding machine-readable source code, which 250 | must be distributed under the terms of Sections 1 and 2 above on a 251 | medium customarily used for software interchange. 252 | 253 | If distribution of object code is made by offering access to copy 254 | from a designated place, then offering equivalent access to copy the 255 | source code from the same place satisfies the requirement to 256 | distribute the source code, even though third parties are not 257 | compelled to copy the source along with the object code. 258 | 259 | 5. A program that contains no derivative of any portion of the 260 | Library, but is designed to work with the Library by being compiled or 261 | linked with it, is called a "work that uses the Library". Such a 262 | work, in isolation, is not a derivative work of the Library, and 263 | therefore falls outside the scope of this License. 264 | 265 | However, linking a "work that uses the Library" with the Library 266 | creates an executable that is a derivative of the Library (because it 267 | contains portions of the Library), rather than a "work that uses the 268 | library". The executable is therefore covered by this License. 269 | Section 6 states terms for distribution of such executables. 270 | 271 | When a "work that uses the Library" uses material from a header file 272 | that is part of the Library, the object code for the work may be a 273 | derivative work of the Library even though the source code is not. 274 | Whether this is true is especially significant if the work can be 275 | linked without the Library, or if the work is itself a library. The 276 | threshold for this to be true is not precisely defined by law. 277 | 278 | If such an object file uses only numerical parameters, data 279 | structure layouts and accessors, and small macros and small inline 280 | functions (ten lines or less in length), then the use of the object 281 | file is unrestricted, regardless of whether it is legally a derivative 282 | work. (Executables containing this object code plus portions of the 283 | Library will still fall under Section 6.) 284 | 285 | Otherwise, if the work is a derivative of the Library, you may 286 | distribute the object code for the work under the terms of Section 6. 287 | Any executables containing that work also fall under Section 6, 288 | whether or not they are linked directly with the Library itself. 289 | 290 | 6. As an exception to the Sections above, you may also combine or 291 | link a "work that uses the Library" with the Library to produce a 292 | work containing portions of the Library, and distribute that work 293 | under terms of your choice, provided that the terms permit 294 | modification of the work for the customer's own use and reverse 295 | engineering for debugging such modifications. 296 | 297 | You must give prominent notice with each copy of the work that the 298 | Library is used in it and that the Library and its use are covered by 299 | this License. You must supply a copy of this License. If the work 300 | during execution displays copyright notices, you must include the 301 | copyright notice for the Library among them, as well as a reference 302 | directing the user to the copy of this License. Also, you must do one 303 | of these things: 304 | 305 | a) Accompany the work with the complete corresponding 306 | machine-readable source code for the Library including whatever 307 | changes were used in the work (which must be distributed under 308 | Sections 1 and 2 above); and, if the work is an executable linked 309 | with the Library, with the complete machine-readable "work that 310 | uses the Library", as object code and/or source code, so that the 311 | user can modify the Library and then relink to produce a modified 312 | executable containing the modified Library. (It is understood 313 | that the user who changes the contents of definitions files in the 314 | Library will not necessarily be able to recompile the application 315 | to use the modified definitions.) 316 | 317 | b) Use a suitable shared library mechanism for linking with the 318 | Library. A suitable mechanism is one that (1) uses at run time a 319 | copy of the library already present on the user's computer system, 320 | rather than copying library functions into the executable, and (2) 321 | will operate properly with a modified version of the library, if 322 | the user installs one, as long as the modified version is 323 | interface-compatible with the version that the work was made with. 324 | 325 | c) Accompany the work with a written offer, valid for at 326 | least three years, to give the same user the materials 327 | specified in Subsection 6a, above, for a charge no more 328 | than the cost of performing this distribution. 329 | 330 | d) If distribution of the work is made by offering access to copy 331 | from a designated place, offer equivalent access to copy the above 332 | specified materials from the same place. 333 | 334 | e) Verify that the user has already received a copy of these 335 | materials or that you have already sent this user a copy. 336 | 337 | For an executable, the required form of the "work that uses the 338 | Library" must include any data and utility programs needed for 339 | reproducing the executable from it. However, as a special exception, 340 | the materials to be distributed need not include anything that is 341 | normally distributed (in either source or binary form) with the major 342 | components (compiler, kernel, and so on) of the operating system on 343 | which the executable runs, unless that component itself accompanies 344 | the executable. 345 | 346 | It may happen that this requirement contradicts the license 347 | restrictions of other proprietary libraries that do not normally 348 | accompany the operating system. Such a contradiction means you cannot 349 | use both them and the Library together in an executable that you 350 | distribute. 351 | 352 | 7. You may place library facilities that are a work based on the 353 | Library side-by-side in a single library together with other library 354 | facilities not covered by this License, and distribute such a combined 355 | library, provided that the separate distribution of the work based on 356 | the Library and of the other library facilities is otherwise 357 | permitted, and provided that you do these two things: 358 | 359 | a) Accompany the combined library with a copy of the same work 360 | based on the Library, uncombined with any other library 361 | facilities. This must be distributed under the terms of the 362 | Sections above. 363 | 364 | b) Give prominent notice with the combined library of the fact 365 | that part of it is a work based on the Library, and explaining 366 | where to find the accompanying uncombined form of the same work. 367 | 368 | 8. You may not copy, modify, sublicense, link with, or distribute 369 | the Library except as expressly provided under this License. Any 370 | attempt otherwise to copy, modify, sublicense, link with, or 371 | distribute the Library is void, and will automatically terminate your 372 | rights under this License. However, parties who have received copies, 373 | or rights, from you under this License will not have their licenses 374 | terminated so long as such parties remain in full compliance. 375 | 376 | 9. You are not required to accept this License, since you have not 377 | signed it. However, nothing else grants you permission to modify or 378 | distribute the Library or its derivative works. These actions are 379 | prohibited by law if you do not accept this License. Therefore, by 380 | modifying or distributing the Library (or any work based on the 381 | Library), you indicate your acceptance of this License to do so, and 382 | all its terms and conditions for copying, distributing or modifying 383 | the Library or works based on it. 384 | 385 | 10. Each time you redistribute the Library (or any work based on the 386 | Library), the recipient automatically receives a license from the 387 | original licensor to copy, distribute, link with or modify the Library 388 | subject to these terms and conditions. You may not impose any further 389 | restrictions on the recipients' exercise of the rights granted herein. 390 | You are not responsible for enforcing compliance by third parties with 391 | this License. 392 | 393 | 11. If, as a consequence of a court judgment or allegation of patent 394 | infringement or for any other reason (not limited to patent issues), 395 | conditions are imposed on you (whether by court order, agreement or 396 | otherwise) that contradict the conditions of this License, they do not 397 | excuse you from the conditions of this License. If you cannot 398 | distribute so as to satisfy simultaneously your obligations under this 399 | License and any other pertinent obligations, then as a consequence you 400 | may not distribute the Library at all. For example, if a patent 401 | license would not permit royalty-free redistribution of the Library by 402 | all those who receive copies directly or indirectly through you, then 403 | the only way you could satisfy both it and this License would be to 404 | refrain entirely from distribution of the Library. 405 | 406 | If any portion of this section is held invalid or unenforceable under any 407 | particular circumstance, the balance of the section is intended to apply, 408 | and the section as a whole is intended to apply in other circumstances. 409 | 410 | It is not the purpose of this section to induce you to infringe any 411 | patents or other property right claims or to contest validity of any 412 | such claims; this section has the sole purpose of protecting the 413 | integrity of the free software distribution system which is 414 | implemented by public license practices. Many people have made 415 | generous contributions to the wide range of software distributed 416 | through that system in reliance on consistent application of that 417 | system; it is up to the author/donor to decide if he or she is willing 418 | to distribute software through any other system and a licensee cannot 419 | impose that choice. 420 | 421 | This section is intended to make thoroughly clear what is believed to 422 | be a consequence of the rest of this License. 423 | 424 | 12. If the distribution and/or use of the Library is restricted in 425 | certain countries either by patents or by copyrighted interfaces, the 426 | original copyright holder who places the Library under this License may add 427 | an explicit geographical distribution limitation excluding those countries, 428 | so that distribution is permitted only in or among countries not thus 429 | excluded. In such case, this License incorporates the limitation as if 430 | written in the body of this License. 431 | 432 | 13. The Free Software Foundation may publish revised and/or new 433 | versions of the Lesser General Public License from time to time. 434 | Such new versions will be similar in spirit to the present version, 435 | but may differ in detail to address new problems or concerns. 436 | 437 | Each version is given a distinguishing version number. If the Library 438 | specifies a version number of this License which applies to it and 439 | "any later version", you have the option of following the terms and 440 | conditions either of that version or of any later version published by 441 | the Free Software Foundation. If the Library does not specify a 442 | license version number, you may choose any version ever published by 443 | the Free Software Foundation. 444 | 445 | 14. If you wish to incorporate parts of the Library into other free 446 | programs whose distribution conditions are incompatible with these, 447 | write to the author to ask for permission. For software which is 448 | copyrighted by the Free Software Foundation, write to the Free 449 | Software Foundation; we sometimes make exceptions for this. Our 450 | decision will be guided by the two goals of preserving the free status 451 | of all derivatives of our free software and of promoting the sharing 452 | and reuse of software generally. 453 | 454 | NO WARRANTY 455 | 456 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 457 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 458 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 459 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 460 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 461 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 462 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 463 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 464 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 465 | 466 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 467 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 468 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 469 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 470 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 471 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 472 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 473 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 474 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 475 | DAMAGES. 476 | 477 | END OF TERMS AND CONDITIONS 478 | 479 | How to Apply These Terms to Your New Libraries 480 | 481 | If you develop a new library, and you want it to be of the greatest 482 | possible use to the public, we recommend making it free software that 483 | everyone can redistribute and change. You can do so by permitting 484 | redistribution under these terms (or, alternatively, under the terms of the 485 | ordinary General Public License). 486 | 487 | To apply these terms, attach the following notices to the library. It is 488 | safest to attach them to the start of each source file to most effectively 489 | convey the exclusion of warranty; and each file should have at least the 490 | "copyright" line and a pointer to where the full notice is found. 491 | 492 | 493 | Copyright (C) 494 | 495 | This library is free software; you can redistribute it and/or 496 | modify it under the terms of the GNU Lesser General Public 497 | License as published by the Free Software Foundation; either 498 | version 2.1 of the License, or (at your option) any later version. 499 | 500 | This library is distributed in the hope that it will be useful, 501 | but WITHOUT ANY WARRANTY; without even the implied warranty of 502 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 503 | Lesser General Public License for more details. 504 | 505 | You should have received a copy of the GNU Lesser General Public 506 | License along with this library; if not, write to the Free Software 507 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 508 | 509 | Also add information on how to contact you by electronic and paper mail. 510 | 511 | You should also get your employer (if you work as a programmer) or your 512 | school, if any, to sign a "copyright disclaimer" for the library, if 513 | necessary. Here is a sample; alter the names: 514 | 515 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 516 | library `Frob' (a library for tweaking knobs) written by James Random Hacker. 517 | 518 | , 1 April 1990 519 | Ty Coon, President of Vice 520 | 521 | That's all there is to it! 522 | -------------------------------------------------------------------------------- /META-camlzip: -------------------------------------------------------------------------------- 1 | requires="zip" -------------------------------------------------------------------------------- /META-zip: -------------------------------------------------------------------------------- 1 | version="1.13" 2 | requires="unix" 3 | archive(byte)="zip.cma" 4 | archive(native)="zip.cmxa" 5 | archive(native,plugin)="zip.cmxs" 6 | plugin(byte)="zip.cma" 7 | plugin(native)="zip.cmxs" 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ### Configuration section 2 | 3 | # The name of the Zlib library. Usually -lz 4 | ZLIB_LIB=-lz 5 | 6 | # The directory containing the Zlib library (libz.a or libz.so) 7 | # Leave empty if libz is in a standard linker directory 8 | ZLIB_LIBDIR= 9 | # ZLIB_LIBDIR=/usr/local/lib 10 | 11 | # The directory containing the Zlib header file (zlib.h) 12 | # Leave empty if zlib.h is in a standard compiler directory 13 | ZLIB_INCLUDE= 14 | # ZLIB_INCLUDE=/usr/local/include 15 | 16 | ### End of configuration section 17 | 18 | OCAMLC=ocamlfind ocamlc -g -safe-string -bin-annot -package unix 19 | OCAMLOPT=ocamlfind ocamlopt -safe-string -package unix 20 | OCAMLDEP=ocamlfind ocamldep 21 | OCAMLMKLIB=ocamlfind ocamlmklib 22 | 23 | OBJS=zlib.cmo zip.cmo gzip.cmo 24 | C_OBJS=zlibstubs.o 25 | 26 | include $(shell ocamlfind ocamlc -where)/Makefile.config 27 | 28 | ifeq "${NATDYNLINK}" "true" 29 | ZIP_CMXS = zip.cmxs 30 | endif 31 | 32 | ZLIB_L_OPT=$(if $(ZLIB_LIBDIR),-L$(ZLIB_LIBDIR)) 33 | ZLIB_I_OPT=$(if $(ZLIB_INCLUDE),-ccopt -I$(ZLIB_INCLUDE)) 34 | 35 | all:: allbyt 36 | ifneq "${ARCH}" "none" 37 | ifneq "${NATIVE_COMPILER}" "false" 38 | all:: allopt 39 | endif 40 | endif 41 | 42 | allbyt: libcamlzip$(EXT_LIB) zip.cma 43 | 44 | allopt: libcamlzip$(EXT_LIB) zip.cmxa $(ZIP_CMXS) 45 | 46 | zip.cma: $(OBJS) 47 | $(OCAMLMKLIB) -o zip -oc camlzip $(OBJS) $(ZLIB_L_OPT) $(ZLIB_LIB) 48 | 49 | zip.cmxa: $(OBJS:.cmo=.cmx) 50 | $(OCAMLMKLIB) -o zip -oc camlzip $(OBJS:.cmo=.cmx) $(ZLIB_L_OPT) $(ZLIB_LIB) 51 | 52 | zip.cmxs: zip.cmxa libcamlzip$(EXT_LIB) 53 | $(OCAMLOPT) -shared -linkall -I ./ -o $@ $^ 54 | 55 | libcamlzip$(EXT_LIB): $(C_OBJS) 56 | $(OCAMLMKLIB) -oc camlzip $(C_OBJS) $(ZLIB_L_OPT) $(ZLIB_LIB) 57 | 58 | .SUFFIXES: .mli .ml .cmo .cmi .cmx 59 | 60 | .mli.cmi: 61 | $(OCAMLC) -c $< 62 | .ml.cmo: 63 | $(OCAMLC) -c $< 64 | .ml.cmx: 65 | $(OCAMLOPT) -c $< 66 | .c.o: 67 | $(OCAMLC) -c -ccopt -g $(ZLIB_I_OPT) $< 68 | 69 | clean: 70 | rm -f *.cm* 71 | rm -f *.o *.a *.so 72 | rm -rf doc/ 73 | 74 | TOINSTALL=\ 75 | *.cma *$(EXT_LIB) \ 76 | *.mli *.cmi *.cmti *.cmt \ 77 | $(wildcard *.cmx) $(wildcard *.cmxa) \ 78 | $(wildcard *.cmxs) $(wildcard *$(EXT_DLL)) 79 | 80 | install-findlib: install 81 | install: 82 | cp META-zip META && \ 83 | ocamlfind install zip META $(TOINSTALL) && \ 84 | rm META 85 | cp META-camlzip META && \ 86 | ocamlfind install camlzip META && \ 87 | rm META 88 | 89 | uninstall: 90 | ocamlfind remove zip 91 | ocamlfind remove camlzip 92 | 93 | depend: 94 | gcc -MM $(ZLIB_I_OPT) *.c > .depend 95 | $(OCAMLDEP) *.mli *.ml >> .depend 96 | 97 | include .depend 98 | 99 | doc: *.mli 100 | mkdir -p doc 101 | ocamldoc -d doc/ -html *.mli 102 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The CamlZip library 2 | 3 | ## DESCRIPTION 4 | 5 | This Objective Caml library provides easy access to compressed files in ZIP and GZIP format, as well as to Java JAR files. It provides functions for reading from and writing to compressed files in these formats. 6 | 7 | ## REQUIREMENTS 8 | 9 | * Objective Caml 4.13 or up. 10 | 11 | * The Findlib / ocamlfind library manager. 12 | 13 | * The Zlib C library, version 1.1.3 or up. You need both the library and its development headers. For Debian and Ubuntu, install the package `zlib1-dev`. For Fedora and RHEL, install the package `zlib-devel`. The Zlib source distribution is at https://zlib.net/ . 14 | 15 | ## INSTALLATION 16 | 17 | * Do `make all`. 18 | 19 | * If it complains that `zlib.h` or `-lz` cannot be found, it is probably because Zlib is installed in non-standard directories. Edit the top of the Makefile to set the appropriate values for `ZLIB_LIBDIR` and `ZLIB_INCLUDE`, or pass these values to `make`, for example: 20 | ``` 21 | make ZLIB_LIBDIR=/opt/lib ZLIB_INCLUDE=/opt/include all 22 | ``` 23 | 24 | * Become super-user if necessary and do `make install`. This installs the library through ocamlfind. 25 | 26 | ## DOCUMENTATION AND USAGE 27 | 28 | See the comments in files zip.mli and gzip.mli. Alternatively, do `make doc` and open the file `./doc/index.html`. 29 | 30 | Compilation: `ocamlfind ocamlopt -package zip ...` 31 | Linking: `ocamlfind ocamlopt -package zip -linkpgk ...` 32 | 33 | The directory test/ contains examples of using this library. 34 | 35 | ## LICENSING 36 | 37 | This library is copyright 2001, 2002, 2006, 2007, 2008, 2016, 2017, 2020 Institut National de Recherche en Informatique et en Automatique (INRIA), and distributed under the terms of the GNU Lesser General Public License (LGPL) version 2.1 or above, with a special exception concerning static linking. See the file LICENSE for the exact licensing terms. 38 | 39 | ## BUG REPORTS AND USER FEEDBACK 40 | 41 | Please use the [issue tracker](https://github.com/xavierleroy/camlzip/issues) 42 | 43 | -------------------------------------------------------------------------------- /camlzip.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "1.13" 3 | synopsis: 4 | "Accessing compressed files in ZIP, GZIP and JAR format" 5 | description: 6 | "The Camlzip library provides easy access to compressed files in ZIP and GZIP format, as well as to Java JAR files. It provides functions for reading from and writing to compressed files in these formats." 7 | maintainer: ["Xavier Leroy "] 8 | authors: ["Xavier Leroy"] 9 | homepage: "https://github.com/xavierleroy/camlzip" 10 | bug-reports: "https://github.com/xavierleroy/camlzip/issues" 11 | dev-repo: "git+https://github.com/xavierleroy/camlzip.git" 12 | license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" 13 | x-maintenance-intent: ["(latest)"] 14 | depends: [ 15 | "ocaml" {>= "4.13.0"} 16 | "ocamlfind" {build} 17 | "conf-zlib" 18 | ] 19 | build: [ 20 | [make "all"] 21 | ] 22 | install: [make "install"] 23 | 24 | -------------------------------------------------------------------------------- /gzip.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Library General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | (* Module [Gzip]: reading and writing to/from [gzip] compressed files *) 17 | 18 | exception Error of string 19 | 20 | let buffer_size = 1024 21 | 22 | type in_channel = 23 | { in_chan: Stdlib.in_channel; 24 | in_buffer: bytes; 25 | mutable in_pos: int; 26 | mutable in_avail: int; 27 | mutable in_eof: bool; 28 | in_stream: Zlib.stream; 29 | mutable in_size: int32; 30 | mutable in_crc: int32 } 31 | 32 | let open_in_chan ic = 33 | (* Superficial parsing of header *) 34 | begin try 35 | let id1 = input_byte ic in 36 | let id2 = input_byte ic in 37 | if id1 <> 0x1F || id2 <> 0x8B then 38 | raise(Error("bad magic number, not a gzip file")); 39 | let cm = input_byte ic in 40 | if cm <> 8 then 41 | raise(Error("unknown compression method")); 42 | let flags = input_byte ic in 43 | if flags land 0xE0 <> 0 then 44 | raise(Error("bad flags, not a gzip file")); 45 | for i = 1 to 6 do ignore(input_byte ic) done; 46 | if flags land 0x04 <> 0 then begin 47 | (* Skip extra data *) 48 | let len1 = input_byte ic in 49 | let len2 = input_byte ic in 50 | for i = 1 to len1 + len2 lsl 8 do ignore(input_byte ic) done 51 | end; 52 | if flags land 0x08 <> 0 then begin 53 | (* Skip original file name *) 54 | while input_byte ic <> 0 do () done 55 | end; 56 | if flags land 0x10 <> 0 then begin 57 | (* Skip comment *) 58 | while input_byte ic <> 0 do () done 59 | end; 60 | if flags land 0x02 <> 0 then begin 61 | (* Skip header CRC *) 62 | ignore(input_byte ic); ignore(input_byte ic) 63 | end 64 | with End_of_file -> 65 | raise(Error("premature end of file, not a gzip file")) 66 | end; 67 | { in_chan = ic; 68 | in_buffer = Bytes.create buffer_size; 69 | in_pos = 0; 70 | in_avail = 0; 71 | in_eof = false; 72 | in_stream = Zlib.inflate_init false; 73 | in_size = Int32.zero; 74 | in_crc = Int32.zero } 75 | 76 | let open_in filename = 77 | let ic = Stdlib.open_in_bin filename in 78 | try 79 | open_in_chan ic 80 | with exn -> 81 | Stdlib.close_in ic; raise exn 82 | 83 | let read_byte iz = 84 | if iz.in_avail = 0 then begin 85 | let n = Stdlib.input iz.in_chan iz.in_buffer 0 86 | (Bytes.length iz.in_buffer) in 87 | if n = 0 then raise End_of_file; 88 | iz.in_pos <- 0; 89 | iz.in_avail <- n 90 | end; 91 | let c = Bytes.get iz.in_buffer iz.in_pos in 92 | iz.in_pos <- iz.in_pos + 1; 93 | iz.in_avail <- iz.in_avail - 1; 94 | Char.code c 95 | 96 | let read_int32 iz = 97 | let b1 = read_byte iz in 98 | let b2 = read_byte iz in 99 | let b3 = read_byte iz in 100 | let b4 = read_byte iz in 101 | Int32.logor (Int32.of_int b1) 102 | (Int32.logor (Int32.shift_left (Int32.of_int b2) 8) 103 | (Int32.logor (Int32.shift_left (Int32.of_int b3) 16) 104 | (Int32.shift_left (Int32.of_int b4) 24))) 105 | 106 | let rec input iz buf pos len = 107 | if pos < 0 || len < 0 || pos + len > Bytes.length buf then 108 | invalid_arg "Gzip.input"; 109 | if iz.in_eof then 0 else begin 110 | if iz.in_avail = 0 then begin 111 | let n = Stdlib.input iz.in_chan iz.in_buffer 0 112 | (Bytes.length iz.in_buffer) in 113 | if n = 0 then raise(Error("truncated file")); 114 | iz.in_pos <- 0; 115 | iz.in_avail <- n 116 | end; 117 | let (finished, used_in, used_out) = 118 | try 119 | Zlib.inflate iz.in_stream iz.in_buffer iz.in_pos iz.in_avail 120 | buf pos len Zlib.Z_SYNC_FLUSH 121 | with Zlib.Error(_, _) -> 122 | raise(Error("error during decompression")) in 123 | iz.in_pos <- iz.in_pos + used_in; 124 | iz.in_avail <- iz.in_avail - used_in; 125 | iz.in_crc <- Zlib.update_crc iz.in_crc buf pos used_out; 126 | iz.in_size <- Int32.add iz.in_size (Int32.of_int used_out); 127 | if finished then begin 128 | try 129 | let crc = read_int32 iz in 130 | let size = read_int32 iz in 131 | if iz.in_crc <> crc then 132 | raise(Error("CRC mismatch, data corrupted")); 133 | if iz.in_size <> size then 134 | raise(Error("size mismatch, data corrupted")); 135 | iz.in_eof <- true; 136 | used_out 137 | with End_of_file -> 138 | raise(Error("truncated file")) 139 | end 140 | else if used_out = 0 then 141 | input iz buf pos len 142 | else 143 | used_out 144 | end 145 | 146 | let rec really_input iz buf pos len = 147 | if len <= 0 then () else begin 148 | let n = input iz buf pos len in 149 | if n = 0 then raise End_of_file; 150 | really_input iz buf (pos + n) (len - n) 151 | end 152 | 153 | let char_buffer = Bytes.create 1 154 | 155 | let input_char iz = 156 | if input iz char_buffer 0 1 = 0 157 | then raise End_of_file 158 | else Bytes.get char_buffer 0 159 | 160 | let input_byte iz = 161 | Char.code (input_char iz) 162 | 163 | let dispose iz = 164 | iz.in_eof <- true; 165 | Zlib.inflate_end iz.in_stream 166 | 167 | let close_in iz = 168 | dispose iz; 169 | Stdlib.close_in iz.in_chan 170 | 171 | type out_channel = 172 | { out_chan: Stdlib.out_channel; 173 | out_buffer: bytes; 174 | mutable out_pos: int; 175 | mutable out_avail: int; 176 | out_stream: Zlib.stream; 177 | mutable out_size: int32; 178 | mutable out_crc: int32 } 179 | 180 | let open_out_chan ?(level = 6) oc = 181 | if level < 1 || level > 9 then invalid_arg "Gzip.open_out: bad level"; 182 | (* Write minimal header *) 183 | output_byte oc 0x1F; (* ID1 *) 184 | output_byte oc 0x8B; (* ID2 *) 185 | output_byte oc 8; (* compression method *) 186 | output_byte oc 0; (* flags *) 187 | for i = 1 to 4 do output_byte oc 0 done; (* mtime *) 188 | output_byte oc 0; (* xflags *) 189 | output_byte oc 0xFF; (* OS (unknown) *) 190 | { out_chan = oc; 191 | out_buffer = Bytes.create buffer_size; 192 | out_pos = 0; 193 | out_avail = buffer_size; 194 | out_stream = Zlib.deflate_init level false; 195 | out_size = Int32.zero; 196 | out_crc = Int32.zero } 197 | 198 | let open_out ?(level = 6) filename = 199 | open_out_chan ~level (Stdlib.open_out_bin filename) 200 | 201 | let flush_and_reset_out_buffer oz = 202 | Stdlib.output oz.out_chan oz.out_buffer 0 oz.out_pos; 203 | oz.out_pos <- 0; 204 | oz.out_avail <- Bytes.length oz.out_buffer 205 | 206 | let rec output oz buf pos len = 207 | if pos < 0 || len < 0 || pos + len > Bytes.length buf then 208 | invalid_arg "Gzip.output"; 209 | (* If output buffer is full, flush it *) 210 | if oz.out_avail = 0 then flush_and_reset_out_buffer oz; 211 | (* Patch request #1428: Zlib disallows zero-length writes *) 212 | if len > 0 then begin 213 | let (_, used_in, used_out) = 214 | try 215 | Zlib.deflate oz.out_stream buf pos len 216 | oz.out_buffer oz.out_pos oz.out_avail 217 | Zlib.Z_NO_FLUSH 218 | with Zlib.Error(_, _) -> 219 | raise (Error("error during compression")) in 220 | oz.out_pos <- oz.out_pos + used_out; 221 | oz.out_avail <- oz.out_avail - used_out; 222 | oz.out_size <- Int32.add oz.out_size (Int32.of_int used_in); 223 | oz.out_crc <- Zlib.update_crc oz.out_crc buf pos used_in; 224 | if used_in < len then output oz buf (pos + used_in) (len - used_in) 225 | end 226 | 227 | let output_substring oz buf pos len = 228 | output oz (Bytes.unsafe_of_string buf) pos len 229 | 230 | let output_char oz c = 231 | Bytes.set char_buffer 0 c; 232 | output oz char_buffer 0 1 233 | 234 | let output_byte oz b = 235 | output_char oz (Char.unsafe_chr b) 236 | 237 | let write_int32 oc n = 238 | let r = ref n in 239 | for i = 1 to 4 do 240 | Stdlib.output_byte oc (Int32.to_int !r); 241 | r := Int32.shift_right_logical !r 8 242 | done 243 | 244 | let flush_to_out_chan ~flush_command oz = 245 | let rec do_flush () = 246 | (* If output buffer is full, flush it *) 247 | if oz.out_avail = 0 then flush_and_reset_out_buffer oz; 248 | let (finished, _, used_out) = 249 | Zlib.deflate oz.out_stream oz.out_buffer 0 0 250 | oz.out_buffer oz.out_pos oz.out_avail 251 | flush_command in 252 | oz.out_pos <- oz.out_pos + used_out; 253 | oz.out_avail <- oz.out_avail - used_out; 254 | (* When we use the Z_FINISH command, we must retry if finished is false. For all other 255 | * flush commands, we should retry if we have filled the output buffer *) 256 | let continue = (flush_command = Zlib.Z_FINISH && not finished) || oz.out_avail = 0 in 257 | if continue then do_flush() in 258 | do_flush(); 259 | (* Final data flush *) 260 | if oz.out_pos > 0 then flush_and_reset_out_buffer oz 261 | 262 | let flush_continue oz = 263 | (* Flush everything to the underlying file channel, then flush the channel. *) 264 | flush_to_out_chan ~flush_command:Zlib.Z_SYNC_FLUSH oz; 265 | Stdlib.flush oz.out_chan 266 | 267 | let flush oz = 268 | (* Flush everything to the output channel. *) 269 | flush_to_out_chan ~flush_command:Zlib.Z_FINISH oz; 270 | (* Write CRC and size *) 271 | write_int32 oz.out_chan oz.out_crc; 272 | write_int32 oz.out_chan oz.out_size; 273 | (* Dispose of stream *) 274 | Zlib.deflate_end oz.out_stream 275 | 276 | let close_out oz = 277 | flush oz; 278 | Stdlib.close_out oz.out_chan 279 | 280 | -------------------------------------------------------------------------------- /gzip.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Library General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | (** Reading and writing to/from [gzip] compressed files 17 | 18 | This module provides functions to read and write compressed data 19 | to/from files in [gzip] format. *) 20 | 21 | (** {1 Reading from compressed files} *) 22 | 23 | type in_channel 24 | (** Abstract type representing a channel opened for reading 25 | from a compressed file. *) 26 | val open_in: string -> in_channel 27 | (** Open a compressed file for reading. The argument is the file 28 | name. *) 29 | val open_in_chan: Stdlib.in_channel -> in_channel 30 | (** Open a compressed file for reading. The argument is a 31 | regular file channel already opened on the compressed file. *) 32 | val input_char: in_channel -> char 33 | (** Uncompress one character from the given channel, and return it. 34 | Raise [End_of_file] if no more compressed data is available. *) 35 | val input_byte: in_channel -> int 36 | (** Same as [Gzip.input_char], but return the 8-bit integer 37 | representing the character. 38 | Raise [End_of_file] if no more compressed data is available. *) 39 | val input: in_channel -> bytes -> int -> int -> int 40 | (** [input ic buf pos len] uncompresses up to [len] characters 41 | from the given channel [ic], 42 | storing them in string [buf], starting at character number [pos]. 43 | It returns the actual number of characters read, between 0 and 44 | [len] (inclusive). 45 | A return value of 0 means that the end of file was reached. 46 | A return value between 0 and [len] exclusive means that 47 | not all requested [len] characters were read, either because 48 | no more characters were available at that time, or because 49 | the implementation found it convenient to do a partial read; 50 | [input] must be called again to read the remaining characters, 51 | if desired. (See also [Gzip.really_input] for reading 52 | exactly [len] characters.) 53 | Exception [Invalid_argument "Gzip.input"] is raised if 54 | [pos] and [len] do not designate a valid substring of [buf]. *) 55 | val really_input: in_channel -> bytes -> int -> int -> unit 56 | (** [really_input ic buf pos len] uncompresses [len] characters 57 | from the given channel, storing them in 58 | string [buf], starting at character number [pos]. 59 | Raise [End_of_file] if fewer than [len] characters can be read. 60 | Raise [Invalid_argument "Gzip.input"] if 61 | [pos] and [len] do not designate a valid substring of [buf]. *) 62 | val close_in: in_channel -> unit 63 | (** Close the given input channel. If the channel was created with 64 | [Gzip.open_in_chan], the underlying regular file channel 65 | (of type [Stdlib.in_channel]) is also closed. 66 | Do not apply any of the functions above to a closed channel. *) 67 | val dispose: in_channel -> unit 68 | (** Same as [Gzip.close_in], but does not close the underlying 69 | regular file channel (of type [Stdlib.in_channel]); 70 | just dispose of the resources associated with the decompression 71 | channel. This can be useful if e.g. the underlying file channel 72 | is a network socket on which more (uncompressed) data 73 | is expected. *) 74 | 75 | (** {1 Writing to compressed files} *) 76 | 77 | type out_channel 78 | (** Abstract type representing a channel opened for writing 79 | to a compressed file. *) 80 | val open_out: ?level:int -> string -> out_channel 81 | (** Open a compressed file for writing. The argument is the file 82 | name. The file is created if it does not exist, or 83 | truncated to zero length if it exists. 84 | The optional [level] argument (an integer between 1 and 9) 85 | indicates the compression level, with 1 being the weakest 86 | (but fastest) compression and 9 being the strongest 87 | (but slowest) compression. The default level is 6 88 | (medium compression). *) 89 | val open_out_chan: ?level:int -> Stdlib.out_channel -> out_channel 90 | (** Open a compressed file for writing. The argument is a 91 | regular file channel already opened on the compressed file. 92 | The optional [level] argument sets the compression level 93 | as documented for [Gzip.open_out]. *) 94 | val output_char: out_channel -> char -> unit 95 | (** Output one character to the given compressed channel. *) 96 | val output_byte: out_channel -> int -> unit 97 | (** Same as [Gzip.output_char], but the output character is given 98 | by its code. The given integer is taken modulo 256. *) 99 | val output: out_channel -> bytes -> int -> int -> unit 100 | (** [output oc buf pos len] compresses and writes [len] characters 101 | from string [buf], starting at offset [pos], and writes the 102 | compressed data to the channel [oc]. 103 | Raise [Invalid_argument "Gzip.output"] if 104 | [pos] and [len] do not designate a valid substring of [buf]. *) 105 | val output_substring: out_channel -> string -> int -> int -> unit 106 | (** Same as [output], but takes a string as argument instead of 107 | a byte sequence. 108 | @since 1.06 *) 109 | val close_out: out_channel -> unit 110 | (** Close the given output channel. If the channel was created with 111 | [Gzip.open_out_chan], the underlying regular file channel 112 | (of type [Stdlib.out_channel]) is also closed. 113 | Do not apply any of the functions above to a closed channel. *) 114 | val flush: out_channel -> unit 115 | (** Same as [Gzip.close_out], but do not close the underlying 116 | regular file channel (of type [Stdlib.out_channel]); 117 | just flush all pending compressed data and 118 | dispose of the resources associated with the compression 119 | channel. This can be useful if e.g. the underlying file channel 120 | is a network socket on which more data is to be sent. *) 121 | val flush_continue: out_channel -> unit 122 | (** Flush all pending compressed data through both the compression 123 | channel and the underlying regular file channel, but keep both 124 | channels open to accept further data. *) 125 | 126 | (** {1 Error reporting} *) 127 | 128 | exception Error of string 129 | (** Exception raised by the functions above to signal errors during 130 | compression or decompression, or ill-formed input files. *) 131 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | all: test-testzlib test-minizip test-minigzip 2 | 3 | OCAMLOPT=ocamlfind ocamlopt -safe-string -package unix -linkpkg 4 | 5 | minigzip: ../zip.cmxa minigzip.ml 6 | $(OCAMLOPT) -ccopt -g -g -I .. -o minigzip ../zip.cmxa minigzip.ml 7 | 8 | test-minigzip: minigzip minigzip.run 9 | sh ./minigzip.run 10 | 11 | minizip: ../zip.cmxa minizip.ml 12 | $(OCAMLOPT) -ccopt -g -g -I .. -o minizip ../zip.cmxa minizip.ml 13 | 14 | test-minizip: minizip minizip.run 15 | sh ./minizip.run 16 | 17 | testzlib: ../zip.cmxa testzlib.ml 18 | $(OCAMLOPT) -g -I .. -o testzlib ../zip.cmxa testzlib.ml 19 | 20 | test-testzlib: testzlib testzlib.run 21 | sh ./testzlib.run 22 | 23 | clean: 24 | rm -f *.cm* 25 | rm -f minigzip minizip testzlib 26 | -------------------------------------------------------------------------------- /test/bigfiles.run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | here=`pwd` 4 | 5 | tempdir="$1" 6 | if [ -z "$tempdir" ]; then 7 | echo "Usage: bigfiles.run " 1>&2 8 | echo " must have 10 Gb of free space" 1>&2 9 | exit 2 10 | fi 11 | 12 | cd $tempdir 13 | 14 | trap "rm -f zeroes" 0 EXIT INT 15 | 16 | echo "Creating big file..." 17 | dd if=/dev/zero of=zeroes bs=1000000 count=5120 18 | echo "Running the tests..." 19 | 20 | runtest() { 21 | rm -rf result minizip.zip 22 | mkdir result 23 | if ($2 ./minizip.zip zeroes > /dev/null && \ 24 | (cd result && $3 ../minizip.zip > /dev/null) && \ 25 | cmp result/zeroes zeroes) 26 | then rm -rf result minizip.zip; echo "$1: passed" 27 | else rm -rf result minizip.zip; echo "$1: FAILED"; exit 2 28 | fi 29 | } 30 | 31 | runtest "Big file 1" "$here/minizip c" "$here/minizip x" 32 | runtest "Big file 2" "zip -r" "$here/minizip x" 33 | runtest "Big file 3" "$here/minizip c" "unzip" 34 | -------------------------------------------------------------------------------- /test/manyfiles.run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | here=`pwd` 4 | 5 | tempdir="$1" 6 | if [ -z "$tempdir" ]; then 7 | echo "Usage: manyfiles.run " 1>&2 8 | echo " must have 10 Gb of free space" 1>&2 9 | exit 2 10 | fi 11 | 12 | cd $tempdir 13 | 14 | trap "rm -rf hier" 0 EXIT INT 15 | 16 | echo "Creating file hierarchy..." 17 | rm -rf hier 18 | mkdir hier hier/1 19 | j=1 20 | while [ $j -le 300 ]; do 21 | dd if=/dev/zero of=hier/1/$j bs=50000 count=1 status=none 22 | j=`expr $j + 1` 23 | done 24 | i=2 25 | while [ $i -le 300 ]; do 26 | ln -s 1 hier/$i 27 | i=`expr $i + 1` 28 | done 29 | echo "Running the tests..." 30 | 31 | runtest() { 32 | rm -rf result minizip.zip 33 | mkdir result 34 | if ($2 ./minizip.zip hier > /dev/null && \ 35 | (cd result && $3 ../minizip.zip > /dev/null) && \ 36 | diff -q -r result/hier hier) 37 | then rm -rf result minizip.zip; echo "$1: passed" 38 | else rm -rf result minizip.zip; echo "$1: FAILED"; exit 2 39 | fi 40 | } 41 | 42 | runtest "Many files 1" "$here/minizip c" "$here/minizip x" 43 | runtest "Many files 2" "zip -r" "$here/minizip x" 44 | runtest "Many files 3" "$here/minizip c" "unzip" 45 | -------------------------------------------------------------------------------- /test/minigzip.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Library General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | let buffer = Bytes.create 4096 17 | 18 | let _ = 19 | if Array.length Sys.argv >= 2 && Sys.argv.(1) = "-d" then begin 20 | (* decompress *) 21 | let ic = Gzip.open_in_chan stdin in 22 | let rec decompress () = 23 | let n = Gzip.input ic buffer 0 (Bytes.length buffer) in 24 | if n = 0 then () else begin output stdout buffer 0 n; decompress() end 25 | in decompress(); Gzip.dispose ic 26 | end else begin 27 | (* compress *) 28 | let oc = Gzip.open_out_chan stdout in 29 | let rec compress () = 30 | let n = input stdin buffer 0 (Bytes.length buffer) in 31 | if n = 0 then () else begin Gzip.output oc buffer 0 n; Gzip.flush_continue oc; compress() end 32 | in compress(); Gzip.flush oc 33 | end 34 | -------------------------------------------------------------------------------- /test/minigzip.run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | runtest() { 4 | if $2 < minigzip.ml | $3 -d | cmp - minigzip.ml 5 | then echo "$1: passed" 6 | else echo "$1: FAILED"; exit 2 7 | fi 8 | } 9 | 10 | runtest "Gzip 1" ./minigzip ./minigzip 11 | runtest "Gzip 2" ./minigzip gzip 12 | runtest "Gzip 3" gzip ./minigzip 13 | -------------------------------------------------------------------------------- /test/minizip.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Library General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | open Printf 17 | 18 | let list_entry e = 19 | let t = Unix.localtime e.Zip.mtime in 20 | printf "%6d %6d %c %04d-%02d-%02d %02d:%02d %c %s\n" 21 | e.Zip.uncompressed_size 22 | e.Zip.compressed_size 23 | (match e.Zip.methd with Zip.Stored -> 's' | Zip.Deflated -> 'd') 24 | (t.Unix.tm_year + 1900) (t.Unix.tm_mon + 1) t.Unix.tm_mday 25 | t.Unix.tm_hour t.Unix.tm_min 26 | (if e.Zip.is_directory then 'd' else ' ') 27 | e.Zip.filename; 28 | if e.Zip.comment <> "" then 29 | printf " %s\n" e.Zip.comment 30 | 31 | let list zipfile = 32 | let ic = Zip.open_in zipfile in 33 | if Zip.comment ic <> "" then printf "%s\n" (Zip.comment ic); 34 | List.iter list_entry (Zip.entries ic); 35 | Zip.close_in ic 36 | 37 | let extract_entry ifile e = 38 | print_string e.Zip.filename; print_newline(); 39 | if e.Zip.is_directory then begin 40 | try 41 | Unix.mkdir e.Zip.filename 0o777 42 | with Unix.Unix_error(Unix.EEXIST, _, _) -> () 43 | end else begin 44 | Zip.copy_entry_to_file ifile e e.Zip.filename 45 | end 46 | 47 | let extract zipfile = 48 | let ic = Zip.open_in zipfile in 49 | List.iter (extract_entry ic) (Zip.entries ic); 50 | Zip.close_in ic 51 | 52 | let rec add_entry oc file = 53 | let s = Unix.stat file in 54 | match s.Unix.st_kind with 55 | Unix.S_REG -> 56 | printf "Adding file %s\n" file; flush stdout; 57 | Zip.copy_file_to_entry file oc ~mtime:s.Unix.st_mtime file 58 | | Unix.S_DIR -> 59 | printf "Adding directory %s\n" file; flush stdout; 60 | Zip.add_entry "" oc ~mtime:s.Unix.st_mtime 61 | (if Filename.check_suffix file "/" then file else file ^ "/"); 62 | let d = Unix.opendir file in 63 | begin try 64 | while true do 65 | let e = Unix.readdir d in 66 | if e <> "." && e <> ".." then add_entry oc (Filename.concat file e) 67 | done 68 | with End_of_file -> () 69 | end; 70 | Unix.closedir d 71 | | _ -> () 72 | 73 | let create zipfile files = 74 | let oc = Zip.open_out zipfile in 75 | Array.iter (add_entry oc) files; 76 | Zip.close_out oc 77 | 78 | let append zipfile files = 79 | let oc = Zip.open_update zipfile in 80 | Array.iter (add_entry oc) files; 81 | Zip.close_out oc 82 | 83 | let usage() = 84 | prerr_string 85 | {|Usage: 86 | minizip t show contents of 87 | minizip x extract files from 88 | minizip c .. create a with the given files 89 | minizip a .. add the given files to 90 | |}; 91 | exit 2 92 | 93 | let _ = 94 | if Array.length Sys.argv < 3 then usage(); 95 | match Sys.argv.(1) with 96 | "t" -> list Sys.argv.(2) 97 | | "x" -> extract Sys.argv.(2) 98 | | "c" -> create Sys.argv.(2) 99 | (Array.sub Sys.argv 3 (Array.length Sys.argv - 3)) 100 | | "a" -> append Sys.argv.(2) 101 | (Array.sub Sys.argv 3 (Array.length Sys.argv - 3)) 102 | | _ -> usage() 103 | -------------------------------------------------------------------------------- /test/minizip.run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | here=`pwd` 4 | 5 | runtest() { 6 | d=/tmp/minizip$$ 7 | zf=/tmp/minizip$$.zip 8 | rm -rf $d $zf 9 | mkdir $d 10 | if $2 $zf * > /dev/null && \ 11 | (cd $d && $3 $zf > /dev/null) && \ 12 | cmp minizip.ml $d/minizip.ml && \ 13 | cmp minigzip.ml $d/minigzip.ml 14 | then rm -rf $d $zf; echo "$1: passed" 15 | else rm -rf $d $zf; echo "$1: FAILED"; exit 2 16 | fi 17 | } 18 | 19 | appendtest() { 20 | d=/tmp/minizip$$ 21 | zf=/tmp/minizip$$.zip 22 | rm -rf $d $zf 23 | mkdir $d 24 | if $here/minizip c $zf *.ml > /dev/null && \ 25 | $here/minizip a $zf *.run > /dev/null && \ 26 | $here/minizip a $zf minigzip.ml > /dev/null && \ 27 | (cd $d && unzip $zf > /dev/null) && \ 28 | cmp minizip.ml $d/minizip.ml && \ 29 | cmp minigzip.ml $d/minigzip.ml 30 | then rm -rf $d $zf; echo "Zip 4: passed" 31 | else rm -rf $d $zf; echo "Zip 4: FAILED"; exit 2 32 | fi 33 | } 34 | 35 | runtest "Zip 1" "$here/minizip c" "$here/minizip x" 36 | runtest "Zip 2" "zip -r" "$here/minizip x" 37 | runtest "Zip 3" "$here/minizip c" "unzip" 38 | appendtest 39 | 40 | 41 | -------------------------------------------------------------------------------- /test/testzlib.ml: -------------------------------------------------------------------------------- 1 | let compress infile outfile = 2 | let ic = open_in_bin infile 3 | and oc = open_out_bin outfile in 4 | Zlib.compress (fun buf -> input ic buf 0 (Bytes.length buf)) 5 | (fun buf len -> output oc buf 0 len); 6 | close_in ic; 7 | close_out oc 8 | 9 | let uncompress infile outfile = 10 | let ic = open_in_bin infile 11 | and oc = open_out_bin outfile in 12 | Zlib.uncompress (fun buf -> input ic buf 0 (Bytes.length buf)) 13 | (fun buf len -> output oc buf 0 len); 14 | close_in ic; 15 | close_out oc 16 | 17 | let _ = 18 | if Array.length Sys.argv >= 4 && Sys.argv.(1) = "-d" then 19 | uncompress Sys.argv.(2) Sys.argv.(3) 20 | else if Array.length Sys.argv >= 3 then 21 | compress Sys.argv.(1) Sys.argv.(2) 22 | -------------------------------------------------------------------------------- /test/testzlib.run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | t1=`mktemp` 4 | t2=`mktemp` 5 | if ./testzlib testzlib.ml $t1 && ./testzlib -d $t1 $t2 && cmp $t2 testzlib.ml 6 | then rm -f $t1 $t2; echo "Zlib: passed" 7 | else rm -f $t1 $t2; echo "Zlib: FAILED"; exit 2 8 | fi 9 | -------------------------------------------------------------------------------- /zip.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Lesser General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | (* Module [Zip]: reading and writing ZIP archives *) 17 | 18 | exception Error of string * string * string 19 | 20 | let int64_of_uint32 n = 21 | Int64.(logand (of_int32 n) 0xFFFF_FFFFL) 22 | 23 | let read1 = input_byte 24 | let read2 ic = 25 | let lb = read1 ic in let hb = read1 ic in lb lor (hb lsl 8) 26 | let read4 ic = 27 | let lw = read2 ic in let hw = read2 ic in 28 | Int32.logor (Int32.of_int lw) (Int32.shift_left (Int32.of_int hw) 16) 29 | let read8 ic = 30 | let ll = read4 ic in let hl = read4 ic in 31 | Int64.logor (int64_of_uint32 ll) (Int64.shift_left (int64_of_uint32 hl) 32) 32 | 33 | let readstring ic n = 34 | let s = Bytes.create n in 35 | really_input ic s 0 n; Bytes.unsafe_to_string s 36 | 37 | let write1 = output_byte 38 | let write2 oc n = 39 | write1 oc n; write1 oc (n lsr 8) 40 | let write4 oc n = 41 | write2 oc (Int32.to_int n); 42 | write2 oc (Int32.to_int (Int32.shift_right_logical n 16)) 43 | let write8 oc n = 44 | write4 oc (Int64.to_int32 n); 45 | write4 oc (Int64.to_int32 (Int64.shift_right_logical n 32)) 46 | let writestring oc s = 47 | output_string oc s 48 | 49 | type compression_method = Stored | Deflated 50 | 51 | type entry = 52 | { filename: string; 53 | comment: string; 54 | methd: compression_method; 55 | mtime: float; 56 | crc: int32; 57 | uncompressed_size: int; 58 | compressed_size: int; 59 | is_directory: bool; 60 | file_offset: int64 } 61 | 62 | type in_file = 63 | { if_filename: string; 64 | if_channel: Stdlib.in_channel; 65 | if_entries: entry list; 66 | if_directory: (string, entry) Hashtbl.t; 67 | if_comment: string } 68 | 69 | let entries ifile = ifile.if_entries 70 | let comment ifile = ifile.if_comment 71 | 72 | type out_file = 73 | { of_filename: string; 74 | of_channel: Stdlib.out_channel; 75 | mutable of_entries: entry list; 76 | of_comment: string } 77 | 78 | (* Return the position of the last occurrence of [pattern] in [buf], 79 | or -1 if not found. *) 80 | 81 | let strrstr (pattern: string) (buf: bytes) ofs len = 82 | let rec search i j = 83 | if i < ofs then -1 84 | else if j >= String.length pattern then i 85 | else if String.get pattern j = Bytes.get buf (i + j) then search i (j+1) 86 | else search (i-1) 0 87 | in search (ofs + len - String.length pattern) 0 88 | 89 | (* Determine if a file name is a directory (ends with /) *) 90 | 91 | let filename_is_directory name = 92 | String.length name > 0 && name.[String.length name - 1] = '/' 93 | 94 | (* Convert between Unix dates and DOS dates *) 95 | 96 | let unixtime_of_dostime time date = 97 | fst(Unix.mktime 98 | { Unix.tm_sec = (time lsl 1) land 0x3e; 99 | Unix.tm_min = (time lsr 5) land 0x3f; 100 | Unix.tm_hour = (time lsr 11) land 0x1f; 101 | Unix.tm_mday = date land 0x1f; 102 | Unix.tm_mon = ((date lsr 5) land 0xf) - 1; 103 | Unix.tm_year = ((date lsr 9) land 0x7f) + 80; 104 | Unix.tm_wday = 0; 105 | Unix.tm_yday = 0; 106 | Unix.tm_isdst = false }) 107 | 108 | let dostime_of_unixtime t = 109 | let tm = Unix.localtime t in 110 | (tm.Unix.tm_sec lsr 1 111 | + (tm.Unix.tm_min lsl 5) 112 | + (tm.Unix.tm_hour lsl 11), 113 | tm.Unix.tm_mday 114 | + (tm.Unix.tm_mon + 1) lsl 5 115 | + (tm.Unix.tm_year - 80) lsl 9) 116 | 117 | (* Parse the extra fields attached to some other structures *) 118 | 119 | let parse_extra_field ef = 120 | let rec parse accu pos = 121 | if pos + 4 > String.length ef then List.rev accu else begin 122 | let id = String.get_uint16_le ef pos in 123 | let sz = String.get_uint16_le ef (pos + 2) in 124 | let sz = min sz (String.length ef - (pos + 4)) in 125 | let data = String.sub ef (pos + 4) sz in 126 | parse ((id, data) :: accu) (pos + 4 + sz) 127 | end 128 | in parse [] 0 129 | 130 | (* Locate the end of central directory record *) 131 | 132 | let locate_ecd filename ic = 133 | let buf = Bytes.create 256 in 134 | let filelen = LargeFile.in_channel_length ic in 135 | let rec find_ecd pos len = 136 | (* On input, bytes 0 ... len - 1 of buf reflect what is at pos in ic *) 137 | if pos <= 0L || Int64.sub filelen pos >= 0x10000L then 138 | raise (Error(filename, "", 139 | "end of central directory not found, not a ZIP file")); 140 | let toread = if pos >= 128L then 128 else Int64.to_int pos in 141 | (* Make room for "toread" extra bytes, and read them *) 142 | Bytes.blit buf 0 buf toread (256 - toread); 143 | let newpos = Int64.(sub pos (of_int toread)) in 144 | LargeFile.seek_in ic newpos; 145 | really_input ic buf 0 toread; 146 | let newlen = min (toread + len) 256 in 147 | (* Search for magic number *) 148 | let ofs = strrstr "PK\005\006" buf 0 newlen in 149 | if ofs >= 0 && newlen >= 22 && 150 | (let comment_len = Bytes.get_uint16_le buf (ofs + 20) in 151 | Int64.(add newpos (of_int (ofs + 22 + comment_len)))= filelen) 152 | then Int64.(add newpos (of_int ofs)) 153 | else find_ecd newpos newlen 154 | in find_ecd filelen 0 155 | 156 | (* Read ZIP64 end of central directory record locator *) 157 | 158 | let read_ecd64_locator filename ic ecd_pos = 159 | if ecd_pos < 20L then 160 | raise(Error(filename, "", "ZIP64 ECD record locator missing")); 161 | let ecd64_locator_pos = Int64.(sub ecd_pos (of_int 20)) in 162 | LargeFile.seek_in ic ecd64_locator_pos ; 163 | let magic = read4 ic in 164 | if magic <> 0x07064b50l then 165 | raise(Error(filename, "", "ZIP64 ECD record locator missing")); 166 | let disk_no = read4 ic in 167 | let ecd64_offset = read8 ic in 168 | let n_disks = read4 ic in 169 | if disk_no <> 0l || n_disks <> 0l then 170 | raise (Error(filename, "", "multi-disk ZIP files not supported")); 171 | ecd64_offset 172 | 173 | (* Read ZIP64 end of central directory record *) 174 | 175 | type cd_info = { 176 | cd_offset: int64; (* file position of start of CD *) 177 | cd_size: int64; (* size of CD in bytes *) 178 | cd_count: int64; (* number of CD entries *) 179 | ecd_comment: string 180 | } 181 | 182 | let read_ecd64 filename ic ecd_pos comment = 183 | let ecd64_pos = read_ecd64_locator filename ic ecd_pos in 184 | LargeFile.seek_in ic ecd64_pos ; 185 | let magic = read4 ic in 186 | if magic <> 0x06064b50l then 187 | raise(Error(filename, "", "ZIP64 ECD record missing")); 188 | let _size = read8 ic in 189 | let _version_made_by = read2 ic in 190 | let version_needed = read2 ic in 191 | let n_disks = read4 ic in 192 | let cd_disk_no = read4 ic in 193 | let _disk_n_entries = read8 ic in 194 | let cd_count = read8 ic in 195 | let cd_size = read8 ic in 196 | let cd_offset = read8 ic in 197 | if version_needed > 45 then 198 | raise(Error(filename, filename, "unsupported ZIP version")); 199 | if cd_disk_no <> 0l || n_disks <> 0l then 200 | raise (Error(filename, "", "multi-disk ZIP files not supported")); 201 | { cd_offset; cd_size; cd_count; ecd_comment = comment } 202 | 203 | (* Read end of central directory record *) 204 | 205 | let read_ecd filename ic = 206 | let ecd_pos = locate_ecd filename ic in 207 | LargeFile.seek_in ic ecd_pos; 208 | let magic = read4 ic in 209 | let disk_no = read2 ic in 210 | let cd_disk_no = read2 ic in 211 | let _disk_entries = read2 ic in 212 | let cd_entries = read2 ic in 213 | let cd_size = read4 ic in 214 | let cd_offset = read4 ic in 215 | let comment_len = read2 ic in 216 | let comment = readstring ic comment_len in 217 | assert (magic = Int32.of_int 0x06054b50); 218 | if disk_no <> 0 || cd_disk_no <> 0 then 219 | raise (Error(filename, "", "multi-disk ZIP files not supported")); 220 | if cd_offset = 0xffff_ffffl || cd_size = 0xffff_ffffl then 221 | read_ecd64 filename ic ecd_pos comment 222 | else 223 | { cd_offset = int64_of_uint32 cd_offset; 224 | cd_size = int64_of_uint32 cd_size; 225 | cd_count = Int64.of_int cd_entries; 226 | ecd_comment = comment } 227 | 228 | (* Fixup sizes from a ZIP64 extended information extra field *) 229 | 230 | let fixup_sizes extra uncompressed_size compressed_size offset = 231 | let pos = ref 0 in 232 | let process orig = 233 | if orig <> 0xFFFF_FFFFl then 234 | int64_of_uint32 orig 235 | else begin 236 | let newval = String.get_int64_le extra !pos in 237 | pos := !pos + 8; 238 | newval 239 | end in 240 | let uncompressed_size = process uncompressed_size in 241 | let compressed_size = process compressed_size in 242 | let offset = process offset in 243 | (uncompressed_size, compressed_size, offset) 244 | 245 | (* Read central directory entry *) 246 | 247 | let read_directory_entry filename ic = 248 | let magic = read4 ic in 249 | if magic <> 0x02014b50l then 250 | raise (Error(filename, "", "wrong file header in central directory")); 251 | let _version_made_by = read2 ic in 252 | let version_needed = read2 ic in 253 | let flags = read2 ic in 254 | let methd = read2 ic in 255 | let lastmod_time = read2 ic in 256 | let lastmod_date = read2 ic in 257 | let crc = read4 ic in 258 | let compr_size = read4 ic in 259 | let uncompr_size = read4 ic in 260 | let name_len = read2 ic in 261 | let extra_len = read2 ic in 262 | let comment_len = read2 ic in 263 | let _disk_number = read2 ic in 264 | let _internal_attr = read2 ic in 265 | let _external_attr = read4 ic in 266 | let header_offset = read4 ic in 267 | let name = readstring ic name_len in 268 | let extra = readstring ic extra_len in 269 | let comment = readstring ic comment_len in 270 | if version_needed > 45 then 271 | raise(Error(filename, name, "unsupported ZIP version")); 272 | if flags land 1 <> 0 then 273 | raise (Error(filename, name, "encrypted entries not supported")); 274 | let (uncompressed_size, compressed_size, file_offset) = 275 | if compr_size <> 0xffff_ffffl 276 | && uncompr_size <> 0xffff_ffffl 277 | && header_offset <> 0xffff_ffffl 278 | then 279 | (int64_of_uint32 uncompr_size, 280 | int64_of_uint32 compr_size, 281 | int64_of_uint32 header_offset) 282 | else begin 283 | match List.assoc_opt 1 (parse_extra_field extra) with 284 | | None -> 285 | raise(Error(filename, name, "ZIP64 extensible data record missing")) 286 | | Some e -> 287 | fixup_sizes e uncompr_size compr_size header_offset 288 | end in 289 | let int_of_uint64 n = 290 | if n >= 0L && n <= Int64.of_int max_int 291 | then Int64.to_int n 292 | else raise(Error(filename, name, "size too large to be represented")) 293 | in 294 | { filename = name; 295 | comment = comment; 296 | methd = (match methd with 297 | | 0 -> Stored 298 | | 8 -> Deflated 299 | | _ -> raise (Error(filename, name, 300 | "unknown compression method"))); 301 | mtime = unixtime_of_dostime lastmod_time lastmod_date; 302 | crc = crc; 303 | uncompressed_size = int_of_uint64 uncompressed_size; 304 | compressed_size = int_of_uint64 compressed_size; 305 | is_directory = filename_is_directory name; 306 | file_offset 307 | } 308 | 309 | (* Read central directory *) 310 | 311 | let read_cd filename ic cdinfo = 312 | try 313 | LargeFile.seek_in ic cdinfo.cd_offset; 314 | let entries = ref [] in 315 | let entrycnt = ref Int64.zero in 316 | let cd_bound = Int64.add cdinfo.cd_offset cdinfo.cd_size in 317 | while LargeFile.pos_in ic < cd_bound do 318 | entrycnt := Int64.(add !entrycnt one) ; 319 | let e = read_directory_entry filename ic in 320 | entries := e :: !entries 321 | done; 322 | if cd_bound <> LargeFile.pos_in ic 323 | || (cdinfo.cd_count <> !entrycnt && cdinfo.cd_count <> 0xFFFFL) 324 | then 325 | raise(Error(filename, "", 326 | "wrong number of entries in central directory")); 327 | List.rev !entries 328 | with End_of_file -> 329 | raise (Error(filename, "", "end-of-file while reading central directory")) 330 | 331 | (* Open a ZIP file for reading *) 332 | 333 | let open_in filename = 334 | let ic = Stdlib.open_in_bin filename in 335 | try 336 | let cdinfo = read_ecd filename ic in 337 | let entries = read_cd filename ic cdinfo in 338 | let table_size = 339 | match Int64.(div cdinfo.cd_count 3L |> unsigned_to_int) with 340 | Some sz -> sz 341 | | None -> 65535 in 342 | let dir = Hashtbl.create table_size in 343 | List.iter (fun e -> Hashtbl.add dir e.filename e) entries; 344 | { if_filename = filename; 345 | if_channel = ic; 346 | if_entries = entries; 347 | if_directory = dir; 348 | if_comment = cdinfo.ecd_comment } 349 | with exn -> 350 | Stdlib.close_in ic; raise exn 351 | 352 | (* Close a ZIP file opened for reading *) 353 | 354 | let close_in ifile = 355 | Stdlib.close_in ifile.if_channel 356 | 357 | (* Return the info associated with an entry *) 358 | 359 | let find_entry ifile name = 360 | Hashtbl.find ifile.if_directory name 361 | 362 | (* Position on an entry *) 363 | 364 | let goto_entry ifile e = 365 | try 366 | let ic = ifile.if_channel in 367 | LargeFile.seek_in ic e.file_offset; 368 | let magic = read4 ic in 369 | if magic <> 0x04034b50l then 370 | raise (Error(ifile.if_filename, e.filename, "wrong local file header")); 371 | let _version_needed = read2 ic in 372 | let _flags = read2 ic in 373 | let _methd = read2 ic in 374 | let _lastmod_time = read2 ic in 375 | let _lastmod_date = read2 ic in 376 | let _crc = read4 ic in 377 | let _compr_size = read4 ic in 378 | let _uncompr_size = read4 ic in 379 | let filename_len = read2 ic in 380 | let extra_len = read2 ic in 381 | (* Could validate information read against directory entry, but 382 | what the heck *) 383 | LargeFile.seek_in ifile.if_channel 384 | (Int64.add e.file_offset (Int64.of_int (30 + filename_len + extra_len))) 385 | with End_of_file -> 386 | raise (Error(ifile.if_filename, e.filename, "truncated local file header")) 387 | 388 | (* Read the contents of an entry as a string *) 389 | 390 | let read_entry ifile e = 391 | try 392 | goto_entry ifile e; 393 | let res = Bytes.create e.uncompressed_size in 394 | match e.methd with 395 | Stored -> 396 | if e.compressed_size <> e.uncompressed_size then 397 | raise (Error(ifile.if_filename, e.filename, 398 | "wrong size for stored entry")); 399 | really_input ifile.if_channel res 0 e.uncompressed_size; 400 | Bytes.unsafe_to_string res 401 | | Deflated -> 402 | let in_avail = ref e.compressed_size in 403 | let out_pos = ref 0 in 404 | if e.uncompressed_size = 0 then 405 | (* Empty zip entries may be marked as deflated (#44) *) 406 | "" 407 | else begin 408 | begin try 409 | Zlib.uncompress ~header:false 410 | (fun buf -> 411 | let read = input ifile.if_channel buf 0 412 | (min !in_avail (Bytes.length buf)) in 413 | in_avail := !in_avail - read; 414 | read) 415 | (fun buf len -> 416 | if !out_pos + len > Bytes.length res then 417 | raise (Error(ifile.if_filename, e.filename, 418 | "wrong size for deflated entry (too much data)")); 419 | Bytes.blit buf 0 res !out_pos len; 420 | out_pos := !out_pos + len) 421 | with Zlib.Error(_, msg) -> 422 | raise (Error(ifile.if_filename, e.filename, 423 | "decompression error: " ^ msg)) 424 | end; 425 | if !out_pos <> Bytes.length res then 426 | raise (Error(ifile.if_filename, e.filename, 427 | "wrong size for deflated entry (not enough data)")); 428 | let crc = Zlib.update_crc Int32.zero res 0 (Bytes.length res) in 429 | if crc <> e.crc then 430 | raise (Error(ifile.if_filename, e.filename, "CRC mismatch")); 431 | Bytes.unsafe_to_string res 432 | end 433 | with End_of_file -> 434 | raise (Error(ifile.if_filename, e.filename, "truncated data")) 435 | 436 | (* Write the contents of an entry into an out channel *) 437 | 438 | let copy_entry_to_channel ifile e oc = 439 | try 440 | goto_entry ifile e; 441 | match e.methd with 442 | Stored -> 443 | if e.compressed_size <> e.uncompressed_size then 444 | raise (Error(ifile.if_filename, e.filename, 445 | "wrong size for stored entry")); 446 | let buf = Bytes.create 4096 in 447 | let rec copy n = 448 | if n > 0 then begin 449 | let r = input ifile.if_channel buf 0 (min n (Bytes.length buf)) in 450 | output oc buf 0 r; 451 | copy (n - r) 452 | end in 453 | copy e.uncompressed_size 454 | | Deflated -> 455 | let in_avail = ref e.compressed_size in 456 | let crc = ref Int32.zero in 457 | begin try 458 | Zlib.uncompress ~header:false 459 | (fun buf -> 460 | let read = input ifile.if_channel buf 0 461 | (min !in_avail (Bytes.length buf)) in 462 | in_avail := !in_avail - read; 463 | read) 464 | (fun buf len -> 465 | output oc buf 0 len; 466 | crc := Zlib.update_crc !crc buf 0 len) 467 | with Zlib.Error(_, msg) -> 468 | raise (Error(ifile.if_filename, e.filename, 469 | "decompression error: " ^ msg)) 470 | end; 471 | if !crc <> e.crc then 472 | raise (Error(ifile.if_filename, e.filename, "CRC mismatch")) 473 | with End_of_file -> 474 | raise (Error(ifile.if_filename, e.filename, "truncated data")) 475 | 476 | (* Write the contents of an entry to a file *) 477 | 478 | let copy_entry_to_file ifile e outfilename = 479 | let oc = open_out_bin outfilename in 480 | try 481 | copy_entry_to_channel ifile e oc; 482 | close_out oc; 483 | begin try 484 | Unix.utimes outfilename e.mtime e.mtime 485 | with Unix.Unix_error(_, _, _) | Invalid_argument _ -> () 486 | end 487 | with x -> 488 | close_out oc; 489 | Sys.remove outfilename; 490 | raise x 491 | 492 | (* Open a ZIP file for writing *) 493 | 494 | let open_out ?(comment = "") filename = 495 | if String.length comment >= 0x10000 then 496 | raise(Error(filename, "", "comment too long")); 497 | { of_filename = filename; 498 | of_channel = Stdlib.open_out_bin filename; 499 | of_entries = []; 500 | of_comment = comment } 501 | 502 | (* Open an existing ZIP file for updating *) 503 | 504 | let open_update ?comment filename = 505 | let fd = 506 | try Unix.openfile filename [Unix.O_RDWR] 0 507 | with Unix.Unix_error(code, _, _) -> 508 | raise (Sys_error (filename ^ ": " ^ Unix.error_message code)) in 509 | let ic = Unix.in_channel_of_descr fd in 510 | try 511 | let cdinfo = read_ecd filename ic in 512 | let entries = read_cd filename ic cdinfo in 513 | Unix.LargeFile.ftruncate fd cdinfo.cd_offset; 514 | ignore (Unix.LargeFile.lseek fd 0L Unix.SEEK_END); 515 | { of_filename = filename; 516 | of_channel = Unix.out_channel_of_descr fd; 517 | of_entries = entries; 518 | of_comment = Option.value comment ~default:cdinfo.ecd_comment } 519 | with exn -> 520 | Stdlib.close_in ic; raise exn 521 | 522 | (* Reverse list of entries, removing duplicate file names. 523 | Keep only the most recent entry for a given name, i.e. the one that occurs 524 | first in the input list. *) 525 | 526 | module StringSet = Set.Make(String) 527 | 528 | let rev_uniq entries = 529 | let rec rev accu seen = function 530 | | [] -> accu 531 | | e :: l -> 532 | if StringSet.mem e.filename seen 533 | then rev accu seen l 534 | else rev (e :: accu) (StringSet.add e.filename seen) l 535 | in rev [] StringSet.empty entries 536 | 537 | (* Close a ZIP file for writing. Add central directory and ECD. *) 538 | 539 | let write4_cautious oc ov n = 540 | write4 oc (if ov then 0xFFFF_FFFFl else Int64.to_int32 n) 541 | 542 | let write_directory_entry oc e = 543 | let overflow = 544 | e.file_offset > 0xFFFF_FFFFL 545 | || Int64.of_int e.compressed_size > 0xFFFF_FFFFL 546 | || Int64.of_int e.uncompressed_size > 0xFFFF_FFFFL in 547 | write4 oc 0x02014b50l; (* signature *) 548 | let version = match e.methd with Stored -> 10 | Deflated -> 20 in 549 | write2 oc version; (* version made by *) 550 | write2 oc version; (* version needed to extract *) 551 | write2 oc 8; (* flags *) 552 | write2 oc (match e.methd with Stored -> 0 | Deflated -> 8); (* method *) 553 | let (time, date) = dostime_of_unixtime e.mtime in 554 | write2 oc time; (* last mod time *) 555 | write2 oc date; (* last mod date *) 556 | write4 oc e.crc; (* CRC32 *) 557 | write4_cautious oc overflow (Int64.of_int e.compressed_size); 558 | (* compressed size *) 559 | write4_cautious oc overflow (Int64.of_int e.uncompressed_size); 560 | (* uncompressed size *) 561 | write2 oc (String.length e.filename); (* filename length *) 562 | write2 oc (if overflow then 28 else 0); (* extra length *) 563 | write2 oc (String.length e.comment); (* comment length *) 564 | write2 oc 0; (* disk number start *) 565 | write2 oc 0; (* internal attributes *) 566 | write4 oc 0l; (* external attributes *) 567 | write4_cautious oc overflow e.file_offset; (* offset of local header *) 568 | writestring oc e.filename; (* filename *) 569 | if overflow then begin (* extra data *) 570 | write2 oc 0x0001; (* header ID *) 571 | write2 oc 24; (* payload size *) 572 | write8 oc (Int64.of_int e.uncompressed_size); 573 | write8 oc (Int64.of_int e.compressed_size); 574 | write8 oc e.file_offset 575 | end; 576 | writestring oc e.comment (* file comment *) 577 | 578 | let close_out ofile = 579 | let oc = ofile.of_channel in 580 | let start_cd = LargeFile.pos_out oc in 581 | let entries = rev_uniq ofile.of_entries in 582 | List.iter (write_directory_entry oc) entries; 583 | let start_ecd = LargeFile.pos_out oc in 584 | let cd_size = Int64.sub start_ecd start_cd in 585 | let num_entries = List.length entries in 586 | let overflow = 587 | num_entries > 0xFFFF 588 | || start_cd > 0xFFFF_FFFFL 589 | || cd_size > 0xFFFF_FFFFL in 590 | if overflow then begin 591 | (* Write ZIP64 end of central directory record *) 592 | write4 oc 0x06064b50l; (* signature *) 593 | write8 oc 44L; (* size ECD record *) 594 | write2 oc 45; (* version made *) 595 | write2 oc 45; (* version needed *) 596 | write4 oc 0l; (* disk number *) 597 | write4 oc 0l; (* CD disk number *) 598 | let ne = Int64.of_int num_entries in 599 | write8 oc ne; (* num disk entries *) 600 | write8 oc ne; (* num entries *) 601 | write8 oc cd_size; (* size of the CD *) 602 | write8 oc start_cd; (* start offset for CD *) 603 | (* Write ZIP64 end of central directory locator *) 604 | write4 oc 0x07064b50l; (* signature *) 605 | write4 oc 0l; (* CD disk number *) 606 | write8 oc start_ecd; (* Position of ECD record *) 607 | write4 oc 0l (* number of disks *) 608 | end; 609 | (* Write ZIP end of central directory record *) 610 | write4 oc 0x06054b50l; (* signature *) 611 | write2 oc 0; (* disk number *) 612 | write2 oc 0; (* number of disk with central dir *) 613 | let ne = if overflow then 0xFFFF else num_entries in 614 | write2 oc ne; (* # entries in this disk *) 615 | write2 oc ne; (* # entries in central dir *) 616 | write4_cautious oc overflow cd_size; (* size of central dir *) 617 | write4_cautious oc overflow start_cd; (* offset of central dir *) 618 | write2 oc (String.length ofile.of_comment); (* length of comment *) 619 | writestring oc ofile.of_comment; (* comment *) 620 | Stdlib.close_out oc 621 | 622 | (* Write a local file header and return the corresponding entry *) 623 | 624 | let add_entry_header ofile comment level mtime filename = 625 | if level < 0 || level > 9 then 626 | raise(Error(ofile.of_filename, filename, "wrong compression level")); 627 | if String.length filename >= 0x10000 then 628 | raise(Error(ofile.of_filename, filename, "filename too long")); 629 | if not (Filename.is_relative filename) then 630 | raise(Error(ofile.of_filename, filename, "file name must not be absolute")); 631 | if String.length comment >= 0x10000 then 632 | raise(Error(ofile.of_filename, filename, "comment too long")); 633 | let filename = 634 | if Sys.os_type = "Win32" (* normalize directory separators *) 635 | then String.map (function '\\' -> '/' | c -> c) filename 636 | else filename in 637 | let oc = ofile.of_channel in 638 | let pos = LargeFile.pos_out oc in 639 | write4 oc 0x04034b50l; (* signature *) 640 | let version = if level = 0 then 10 else 20 in 641 | write2 oc version; (* version needed to extract *) 642 | write2 oc 0; (* flags *) 643 | write2 oc (if level = 0 then 0 else 8); (* method *) 644 | let (time, date) = dostime_of_unixtime mtime in 645 | write2 oc time; (* last mod time *) 646 | write2 oc date; (* last mod date *) 647 | write4 oc 0l; (* CRC32 - to be filled later *) 648 | write4 oc 0l; (* compressed size - later *) 649 | write4 oc 0l; (* uncompressed size - later *) 650 | write2 oc (String.length filename); (* filename length *) 651 | write2 oc 20; (* extra length *) 652 | writestring oc filename; (* filename *) 653 | write2 oc 0x0001; (* extra data - header ID *) 654 | write2 oc 16; (* payload size *) 655 | write8 oc 0L; (* compressed size - later *) 656 | write8 oc 0L; (* uncompressed size - later *) 657 | { filename = filename; 658 | comment = comment; 659 | methd = (if level = 0 then Stored else Deflated); 660 | mtime = mtime; 661 | crc = Int32.zero; 662 | uncompressed_size = 0; 663 | compressed_size = 0; 664 | is_directory = filename_is_directory filename; 665 | file_offset = pos } 666 | 667 | (* Write the correct sizes and CRC in the local file header 668 | and update the entry *) 669 | 670 | let update_entry ofile crc compr_size uncompr_size entry = 671 | let csz = Int64.of_int compr_size 672 | and usz = Int64.of_int uncompr_size in 673 | let overflow = csz > 0xFFFF_FFFFL || usz > 0xFFFF_FFFFL in 674 | let oc = ofile.of_channel in 675 | let cur = LargeFile.pos_out oc in 676 | LargeFile.seek_out oc (Int64.add entry.file_offset 14L); 677 | write4 oc crc; (* CRC *) 678 | write4_cautious oc overflow csz; (* compressed size *) 679 | write4_cautious oc overflow usz; (* uncompressed size *) 680 | if overflow then begin 681 | LargeFile.seek_out oc 682 | Int64.(add entry.file_offset 683 | (of_int (30 + String.length entry.filename + 4))); 684 | write8 oc csz; (* compressed size *) 685 | write8 oc usz (* uncompressed size *) 686 | end; 687 | LargeFile.seek_out oc cur; 688 | { entry with crc = crc; 689 | uncompressed_size = uncompr_size; 690 | compressed_size = compr_size } 691 | 692 | (* Add an entry with the contents of a string *) 693 | 694 | let add_entry data ofile ?(comment = "") 695 | ?(level = 6) ?(mtime = Unix.time()) name = 696 | let e = add_entry_header ofile comment level mtime name in 697 | let crc = Zlib.update_crc_string Int32.zero data 0 (String.length data) in 698 | let compr_size = 699 | match level with 700 | 0 -> 701 | output_substring ofile.of_channel data 0 (String.length data); 702 | String.length data 703 | | _ -> 704 | let in_pos = ref 0 in 705 | let out_pos = ref 0 in 706 | try 707 | Zlib.compress ~level ~header:false 708 | (fun buf -> 709 | let n = min (String.length data - !in_pos) 710 | (Bytes.length buf) in 711 | String.blit data !in_pos buf 0 n; 712 | in_pos := !in_pos + n; 713 | n) 714 | (fun buf n -> 715 | output ofile.of_channel buf 0 n; 716 | out_pos := !out_pos + n); 717 | !out_pos 718 | with Zlib.Error(_, msg) -> 719 | raise (Error(ofile.of_filename, name, 720 | "compression error: " ^ msg)) in 721 | let e' = update_entry ofile crc compr_size (String.length data) e in 722 | ofile.of_entries <- e' :: ofile.of_entries 723 | 724 | (* Add an entry with the contents of an in channel *) 725 | 726 | let copy_channel_to_entry ic ofile ?(comment = "") 727 | ?(level = 6) ?(mtime = Unix.time()) name = 728 | let e = add_entry_header ofile comment level mtime name in 729 | let crc = ref Int32.zero in 730 | let (compr_size, uncompr_size) = 731 | match level with 732 | 0 -> 733 | let buf = Bytes.create 4096 in 734 | let rec copy sz = 735 | let r = input ic buf 0 (Bytes.length buf) in 736 | if r = 0 then sz else begin 737 | crc := Zlib.update_crc !crc buf 0 r; 738 | output ofile.of_channel buf 0 r; 739 | copy (sz + r) 740 | end in 741 | let size = copy 0 in 742 | (size, size) 743 | | _ -> 744 | let in_pos = ref 0 in 745 | let out_pos = ref 0 in 746 | try 747 | Zlib.compress ~level ~header:false 748 | (fun buf -> 749 | let r = input ic buf 0 (Bytes.length buf) in 750 | crc := Zlib.update_crc !crc buf 0 r; 751 | in_pos := !in_pos + r; 752 | r) 753 | (fun buf n -> 754 | output ofile.of_channel buf 0 n; 755 | out_pos := !out_pos + n); 756 | (!out_pos, !in_pos) 757 | with Zlib.Error(_, msg) -> 758 | raise (Error(ofile.of_filename, name, 759 | "compression error: " ^ msg)) in 760 | let e' = update_entry ofile !crc compr_size uncompr_size e in 761 | ofile.of_entries <- e' :: ofile.of_entries 762 | 763 | (* Add an entry with the contents of a file *) 764 | 765 | let copy_file_to_entry infilename ofile ?(comment = "") 766 | ?(level = 6) ?mtime name = 767 | let ic = open_in_bin infilename in 768 | let mtime' = 769 | match mtime with 770 | Some t -> mtime 771 | | None -> 772 | try Some((Unix.stat infilename).Unix.st_mtime) 773 | with Unix.Unix_error(_,_,_) -> None in 774 | try 775 | copy_channel_to_entry ic ofile ~comment ~level ?mtime:mtime' name; 776 | Stdlib.close_in ic 777 | with x -> 778 | Stdlib.close_in ic; raise x 779 | 780 | 781 | (* Add an entry whose content will be produced by the caller *) 782 | 783 | let add_entry_generator ofile ?(comment = "") 784 | ?(level = 6) ?(mtime = Unix.time()) name = 785 | let e = add_entry_header ofile comment level mtime name in 786 | let crc = ref Int32.zero in 787 | let compr_size = ref 0 in 788 | let uncompr_size = ref 0 in 789 | let finished = ref false in 790 | let check () = 791 | if !finished then 792 | raise (Error(ofile.of_filename, name, "entry already finished")) 793 | in 794 | let finish () = 795 | finished := true; 796 | let e' = update_entry ofile !crc !compr_size !uncompr_size e in 797 | ofile.of_entries <- e' :: ofile.of_entries 798 | in 799 | match level with 800 | | 0 -> 801 | (fun buf pos len -> 802 | check (); 803 | output ofile.of_channel buf pos len; 804 | compr_size := !compr_size + len; 805 | uncompr_size := !uncompr_size + len; 806 | crc := Zlib.update_crc !crc buf pos len 807 | ), 808 | (fun () -> 809 | check (); 810 | finish () 811 | ) 812 | | _ -> 813 | let (send, flush) = Zlib.compress_direct ~level ~header:false 814 | (fun buf n -> 815 | output ofile.of_channel buf 0 n; 816 | compr_size := !compr_size + n) 817 | in 818 | (fun buf pos len -> 819 | check (); 820 | try 821 | send buf pos len; 822 | uncompr_size := !uncompr_size + len; 823 | crc := Zlib.update_crc !crc buf pos len 824 | with Zlib.Error(_, msg) -> 825 | raise (Error(ofile.of_filename, name, 826 | "compression error: " ^ msg)) 827 | ), 828 | (fun () -> 829 | check (); 830 | try 831 | flush (); 832 | finish () 833 | with Zlib.Error(_, msg) -> 834 | raise (Error(ofile.of_filename, name, 835 | "compression error: " ^ msg)) 836 | ) 837 | -------------------------------------------------------------------------------- /zip.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Lesser General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | (** Reading and writing ZIP archives 17 | 18 | This module provides functions for reading and writing ZIP archive 19 | files. ZIP archives package one or more compressed files into 20 | a single ZIP file, along with information about the files, 21 | including file name, date and time of last modification, user-provided 22 | comments, and a checksum to verify the integrity of each entry. 23 | The entries of a ZIP file are not necessarily actual files, and can 24 | actually consist of arbitrary data. 25 | 26 | The ZIP file format used in this module is compatible with that 27 | implemented by the popular [pkzip] archiver under Windows, 28 | and by the Info-ZIP [zip] and [unzip] commands under Unix and Windows. 29 | This format is also compatible with the JAR file format used by Java. *) 30 | 31 | (** {1 Information on ZIP entries} *) 32 | 33 | type compression_method = 34 | | Stored (** data is stored without compression *) 35 | | Deflated (** data is compressed with the ``deflate'' algorithm *) 36 | (** Indicate whether the data in the entry is compressed or not. *) 37 | 38 | type entry = 39 | { filename: string; (** file name for entry *) 40 | comment: string; (** comment attached to entry *) 41 | methd: compression_method; (** compression method *) 42 | mtime: float; (** last modification time (seconds since epoch) *) 43 | crc: int32; (** cyclic redundancy check for data *) 44 | uncompressed_size: int; (** size of original data in bytes *) 45 | compressed_size: int; (** size of compressed data *) 46 | is_directory: bool; (** whether this entry represents a directory *) 47 | file_offset: int64 (** for internal use *) 48 | } 49 | (** Description of an entry in a ZIP file. *) 50 | 51 | (** {1 Reading from ZIP files} *) 52 | 53 | type in_file 54 | (** Abstract type representing a handle opened for reading from 55 | a ZIP file. *) 56 | val open_in: string -> in_file 57 | (** [Zip.open_in zipfilename] opens the ZIP file with the given 58 | filename. The file must already exist. 59 | Return a handle opened for reading from this file. *) 60 | val entries: in_file -> entry list 61 | (** Return a list of all entries in the given ZIP file. *) 62 | val comment: in_file -> string 63 | (** Return the comment attached to the given ZIP file, or the 64 | empty string if none. *) 65 | val find_entry: in_file -> string -> entry 66 | (** [Zip.find_entry zf filename] returns the description of the 67 | entry having name [filename] in the ZIP file [zf]. 68 | Raises [Not_found] if no such entry exists. 69 | The file name must match exactly; in particular, case is 70 | significant. File names must use [/] (slash) as the directory 71 | separator. The name of a directory must end with a trailing 72 | [/] (slash). *) 73 | val read_entry: in_file -> entry -> string 74 | (** [Zip.read_entry zf e] reads and uncompresses the data 75 | (file contents) associated with entry [e] of ZIP file [zf]. 76 | The data is returned as a character string. *) 77 | val copy_entry_to_channel: in_file -> entry -> out_channel -> unit 78 | (** [Zip.copy_entry_to_channel zf e oc] reads and uncompresses 79 | the data associated with entry [e] of ZIP file [zf]. 80 | It then writes this data to the output channel [oc]. *) 81 | val copy_entry_to_file: in_file -> entry -> string -> unit 82 | (** [Zip.copy_entry_to_file zf e destfile] reads and uncompresses 83 | the data associated with entry [e] of ZIP file [zf]. 84 | It then writes this data to the file named [destfile]. 85 | The file [destfile] is created if it does not exist, 86 | and overwritten otherwise. The last modification date of 87 | the file is set to that indicated in the ZIP entry [e], 88 | if possible. *) 89 | val close_in: in_file -> unit 90 | (** Close the given ZIP file handle. If the ZIP file handle was 91 | created by [open_in_channel], the underlying input channel 92 | is closed. *) 93 | 94 | (** {1 Writing to ZIP files} *) 95 | 96 | type out_file 97 | (** Abstract type representing a handle opened for writing to 98 | a ZIP file. *) 99 | val open_out: ?comment: string -> string -> out_file 100 | (** [Zip.open_out zipfilename] creates (or truncates to zero length) 101 | the ZIP file with the given filename. 102 | Return a handle opened for writing to this file. 103 | @param comment comment string attached to the ZIP file as 104 | as whole. Default: empty. *) 105 | val open_update: ?comment: string -> string -> out_file 106 | (** [Zip.open_update zipfilename] opens the ZIP file with the 107 | given filename, preserving its contents. The file must already 108 | exist. Return a handle opened for writing to this file. 109 | Entries added via this handle will be added to the existing 110 | entries. If an entry is added with the same file name as 111 | an existing entry, the old entry becomes inaccessible, only 112 | the new entry remains. 113 | @param comment comment string attached to the ZIP file as 114 | as whole. Default: keep the comment that was attached 115 | to the original ZIP file. *) 116 | val add_entry: 117 | string -> out_file -> 118 | ?comment: string -> ?level: int -> ?mtime: float -> 119 | string -> unit 120 | (** [Zip.add_entry data zf name] adds a new entry to the 121 | ZIP file [zf]. The data (file contents) associated with 122 | the entry is taken from the string [data]. It is compressed 123 | and written to the ZIP file [zf]. [name] is the file name 124 | stored along with this entry. 125 | 126 | Under Windows, backslash characters in the [name] parameter 127 | are stored in the ZIP file as forward slashes [/], for 128 | compatibility with other operating systems. 129 | 130 | Several optional arguments can be provided to control 131 | the format and attached information of the entry: 132 | @param comment attached to the entry (a string). 133 | Default: empty. 134 | @param level compression level for the entry. This is an 135 | integer between 0 and 9, with 0 meaning no compression (store 136 | as is), 1 lowest compression, 9 highest compression. Higher 137 | levels result in smaller compressed data, but longer 138 | compression times. 139 | Default: 6 (moderate compression). 140 | @param mtime last modification time (in seconds since the 141 | epoch). 142 | Default: the current time. *) 143 | 144 | val copy_channel_to_entry: 145 | in_channel -> out_file -> 146 | ?comment: string -> ?level: int -> ?mtime: float -> 147 | string -> unit 148 | (** Same as [Zip.add_entry], but the data associated with the 149 | entry is read from the input channel given as first argument. 150 | The channel is read up to end of file. *) 151 | val copy_file_to_entry: 152 | string -> out_file -> 153 | ?comment: string -> ?level: int -> ?mtime: float -> 154 | string -> unit 155 | (** Same as [Zip.add_entry], but the data associated with the 156 | entry is read from the file whose name is given as first 157 | argument. Also, the default value for the [mtime] 158 | optional parameter is the time of last modification of the 159 | file. *) 160 | val add_entry_generator: 161 | out_file -> 162 | ?comment: string -> ?level: int -> ?mtime: float -> 163 | string -> (bytes -> int -> int -> unit) * (unit -> unit) 164 | (** [Zip.add_entry_generator zf name] returns a pair of functions 165 | [(add, finish)]. It adds a new entry to the 166 | ZIP file [zf]. The file name stored along with this entry 167 | is [name]. Initially, no data is stored in this entry. 168 | To store data in this entry, the program must repeatedly call 169 | the [add] function returned by [Zip.add_entry_generator]. 170 | An invocation [add s ofs len] stores [len] characters of 171 | byte sequence [s] starting at offset [ofs] in the ZIP entry. 172 | When all the data forming the entry has been sent, the 173 | program must call the [finish] function returned by 174 | [Zip.add_entry_generator]. [finish] must be called exactly once. 175 | The optional arguments to [Zip.add_entry_generator] 176 | are as described in {!Zip.add_entry}. *) 177 | val close_out: out_file -> unit 178 | (** Finish writing the ZIP archive by adding the table of 179 | contents, and close it. *) 180 | 181 | (** {1 Error reporting} *) 182 | 183 | exception Error of string * string * string 184 | (** Exception raised when an ill-formed ZIP archive is encountered, 185 | or illegal parameters are given to the functions in this 186 | module. The exception is of the form 187 | [Error(ZIP_name, entry_name, message)] where [ZIP_name] 188 | is the name of the ZIP file, [entry_name] the name of 189 | the offending entry, and [message] an explanation of the 190 | error. *) 191 | -------------------------------------------------------------------------------- /zlib.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Lesser General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | exception Error of string * string 17 | 18 | let _ = 19 | Callback.register_exception "Zlib.Error" (Error("","")) 20 | 21 | type stream 22 | 23 | type flush_command = 24 | Z_NO_FLUSH 25 | | Z_SYNC_FLUSH 26 | | Z_FULL_FLUSH 27 | | Z_FINISH 28 | 29 | external deflate_init: int -> bool -> stream = "camlzip_deflateInit" 30 | external deflate: 31 | stream -> bytes -> int -> int -> bytes -> int -> int -> flush_command 32 | -> bool * int * int 33 | = "camlzip_deflate_bytecode" "camlzip_deflate" 34 | external deflate_string: 35 | stream -> string -> int -> int -> bytes -> int -> int -> flush_command 36 | -> bool * int * int 37 | = "camlzip_deflate_bytecode" "camlzip_deflate" 38 | external deflate_end: stream -> unit = "camlzip_deflateEnd" 39 | 40 | external inflate_init: bool -> stream = "camlzip_inflateInit" 41 | external inflate: 42 | stream -> bytes -> int -> int -> bytes -> int -> int -> flush_command 43 | -> bool * int * int 44 | = "camlzip_inflate_bytecode" "camlzip_inflate" 45 | external inflate_string: 46 | stream -> string -> int -> int -> bytes -> int -> int -> flush_command 47 | -> bool * int * int 48 | = "camlzip_inflate_bytecode" "camlzip_inflate" 49 | external inflate_end: stream -> unit = "camlzip_inflateEnd" 50 | 51 | external update_crc: int32 -> bytes -> int -> int -> int32 52 | = "camlzip_update_crc32" 53 | external update_crc_string: int32 -> string -> int -> int -> int32 54 | = "camlzip_update_crc32" 55 | 56 | let buffer_size = 1024 57 | 58 | let compress ?(level = 6) ?(header = true) refill flush = 59 | let inbuf = Bytes.create buffer_size 60 | and outbuf = Bytes.create buffer_size in 61 | let zs = deflate_init level header in 62 | let rec compr inpos inavail = 63 | if inavail = 0 then begin 64 | let incount = refill inbuf in 65 | if incount = 0 then compr_finish() else compr 0 incount 66 | end else begin 67 | let (_, used_in, used_out) = 68 | deflate zs inbuf inpos inavail outbuf 0 buffer_size Z_NO_FLUSH in 69 | flush outbuf used_out; 70 | compr (inpos + used_in) (inavail - used_in) 71 | end 72 | and compr_finish () = 73 | let (finished, _, used_out) = 74 | deflate zs inbuf 0 0 outbuf 0 buffer_size Z_FINISH in 75 | flush outbuf used_out; 76 | if not finished then compr_finish() 77 | in 78 | compr 0 0; 79 | deflate_end zs 80 | 81 | let compress_direct ?(level = 6) ?(header = true) flush = 82 | let outbuf = Bytes.create buffer_size in 83 | let zs = deflate_init level header in 84 | let rec compr inbuf inpos inavail = 85 | if inavail = 0 then () 86 | else begin 87 | let (_, used_in, used_out) = 88 | deflate zs inbuf inpos inavail outbuf 0 buffer_size Z_NO_FLUSH in 89 | flush outbuf used_out; 90 | compr inbuf (inpos + used_in) (inavail - used_in) 91 | end 92 | and compr_finish () = 93 | let (finished, _, used_out) = 94 | deflate zs (Bytes.unsafe_of_string "") 0 0 95 | outbuf 0 buffer_size Z_FINISH in 96 | flush outbuf used_out; 97 | if not finished then compr_finish() 98 | else deflate_end zs 99 | in 100 | compr, compr_finish 101 | 102 | let uncompress ?(header = true) refill flush = 103 | let inbuf = Bytes.create buffer_size 104 | and outbuf = Bytes.create buffer_size in 105 | let zs = inflate_init header in 106 | let rec uncompr inpos inavail = 107 | if inavail = 0 then begin 108 | let incount = refill inbuf in 109 | if incount = 0 then uncompr_finish 0 else uncompr 0 incount 110 | end else begin 111 | let (finished, used_in, used_out) = 112 | inflate zs inbuf inpos inavail outbuf 0 buffer_size Z_SYNC_FLUSH in 113 | flush outbuf used_out; 114 | if not finished then uncompr (inpos + used_in) (inavail - used_in) 115 | end 116 | and uncompr_finish num_round = 117 | (* Gotcha: if there is no header, inflate requires an extra "dummy" byte 118 | after the compressed stream in order to complete decompression 119 | and return finished = true. *) 120 | let dummy_byte = if num_round = 0 && not header then 1 else 0 in 121 | let (finished, _, used_out) = 122 | inflate zs inbuf 0 dummy_byte outbuf 0 buffer_size Z_SYNC_FLUSH in 123 | flush outbuf used_out; 124 | if finished then () 125 | else if used_out > 0 then uncompr_finish 1 126 | else if num_round < 10 then uncompr_finish (num_round + 1) 127 | else 128 | (* Gotcha: truncated input can cause an infinite loop where 129 | [inflate] doesn't produce output and never returns "finished". 130 | Raise an error after too many calls to [inflate] that produced 131 | no output. *) 132 | raise(Error("Zlib.uncompress", "truncated input data")) 133 | in 134 | uncompr 0 0; 135 | inflate_end zs 136 | -------------------------------------------------------------------------------- /zlib.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* The CamlZip library *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 2001 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU Lesser General Public License, with *) 10 | (* the special exception on linking described in file LICENSE. *) 11 | (* *) 12 | (***********************************************************************) 13 | 14 | (* $Id$ *) 15 | 16 | exception Error of string * string 17 | 18 | val compress: 19 | ?level: int -> ?header: bool -> 20 | (bytes -> int) -> (bytes -> int -> unit) -> unit 21 | 22 | val compress_direct: 23 | ?level: int -> ?header: bool -> (bytes -> int -> unit) -> 24 | (bytes -> int -> int -> unit) * (unit -> unit) 25 | 26 | val uncompress: 27 | ?header: bool -> (bytes -> int) -> (bytes -> int -> unit) -> unit 28 | 29 | type stream 30 | 31 | type flush_command = 32 | Z_NO_FLUSH 33 | | Z_SYNC_FLUSH 34 | | Z_FULL_FLUSH 35 | | Z_FINISH 36 | 37 | external deflate_init: int -> bool -> stream = "camlzip_deflateInit" 38 | external deflate: 39 | stream -> bytes -> int -> int -> bytes -> int -> int -> flush_command 40 | -> bool * int * int 41 | = "camlzip_deflate_bytecode" "camlzip_deflate" 42 | external deflate_string: 43 | stream -> string -> int -> int -> bytes -> int -> int -> flush_command 44 | -> bool * int * int 45 | = "camlzip_deflate_bytecode" "camlzip_deflate" 46 | external deflate_end: stream -> unit = "camlzip_deflateEnd" 47 | 48 | external inflate_init: bool -> stream = "camlzip_inflateInit" 49 | external inflate: 50 | stream -> bytes -> int -> int -> bytes -> int -> int -> flush_command 51 | -> bool * int * int 52 | = "camlzip_inflate_bytecode" "camlzip_inflate" 53 | external inflate_string: 54 | stream -> string -> int -> int -> bytes -> int -> int -> flush_command 55 | -> bool * int * int 56 | = "camlzip_inflate_bytecode" "camlzip_inflate" 57 | external inflate_end: stream -> unit = "camlzip_inflateEnd" 58 | 59 | external update_crc: int32 -> bytes -> int -> int -> int32 60 | = "camlzip_update_crc32" 61 | external update_crc_string: int32 -> string -> int -> int -> int32 62 | = "camlzip_update_crc32" 63 | -------------------------------------------------------------------------------- /zlibstubs.c: -------------------------------------------------------------------------------- 1 | /***********************************************************************/ 2 | /* */ 3 | /* The CamlZip library */ 4 | /* */ 5 | /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ 6 | /* */ 7 | /* Copyright 2001 Institut National de Recherche en Informatique et */ 8 | /* en Automatique. All rights reserved. This file is distributed */ 9 | /* under the terms of the GNU Lesser General Public License, with */ 10 | /* the special exception on linking described in file LICENSE. */ 11 | /* */ 12 | /***********************************************************************/ 13 | 14 | /* $Id$ */ 15 | 16 | /* Stub code to interface with Zlib */ 17 | 18 | #include 19 | #include 20 | 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | #include 27 | 28 | #define ZStream_val(v) (*((z_streamp *) Data_custom_val(v))) 29 | 30 | static const value * camlzip_error_exn = NULL; 31 | 32 | static void camlzip_error(char * fn, value vzs) 33 | { 34 | char * msg; 35 | value s1 = Val_unit, s2 = Val_unit, bucket = Val_unit; 36 | 37 | msg = ZStream_val(vzs)->msg; 38 | if (msg == NULL) msg = ""; 39 | if (camlzip_error_exn == NULL) { 40 | camlzip_error_exn = caml_named_value("Zlib.Error"); 41 | if (camlzip_error_exn == NULL) 42 | caml_invalid_argument("Exception Zlib.Error not initialized"); 43 | } 44 | Begin_roots3(s1, s2, bucket); 45 | s1 = caml_copy_string(fn); 46 | s2 = caml_copy_string(msg); 47 | bucket = caml_alloc_small(3, 0); 48 | Field(bucket, 0) = *camlzip_error_exn; 49 | Field(bucket, 1) = s1; 50 | Field(bucket, 2) = s2; 51 | End_roots(); 52 | caml_raise(bucket); 53 | } 54 | 55 | static void camlzip_free_dstream(value vzs) 56 | { 57 | deflateEnd(ZStream_val(vzs)); 58 | caml_stat_free(ZStream_val(vzs)); 59 | ZStream_val(vzs) = NULL; 60 | } 61 | 62 | static struct custom_operations camlzip_dstream_ops = { 63 | "camlzip_dstream_ops", &camlzip_free_dstream, NULL, NULL, NULL, NULL 64 | }; 65 | 66 | value camlzip_deflateInit(value vlevel, value expect_header) 67 | { 68 | value vzs = 69 | caml_alloc_custom_mem(&camlzip_dstream_ops, 70 | sizeof(z_streamp), sizeof(z_stream)); 71 | ZStream_val(vzs) = caml_stat_alloc(sizeof(z_stream)); 72 | /* Zlib API: the fields zalloc, zfree and opaque must be initialized */ 73 | ZStream_val(vzs)->zalloc = NULL; 74 | ZStream_val(vzs)->zfree = NULL; 75 | ZStream_val(vzs)->opaque = NULL; 76 | if (deflateInit2(ZStream_val(vzs), 77 | Int_val(vlevel), 78 | Z_DEFLATED, 79 | Bool_val(expect_header) ? MAX_WBITS : -MAX_WBITS, 80 | 8, 81 | Z_DEFAULT_STRATEGY) != Z_OK) 82 | camlzip_error("Zlib.deflateInit", vzs); 83 | return vzs; 84 | } 85 | 86 | static int camlzip_flush_table[] = 87 | { Z_NO_FLUSH, Z_SYNC_FLUSH, Z_FULL_FLUSH, Z_FINISH }; 88 | 89 | value camlzip_deflate(value vzs, value srcbuf, value srcpos, value srclen, 90 | value dstbuf, value dstpos, value dstlen, 91 | value vflush) 92 | { 93 | z_stream * zs = ZStream_val(vzs); 94 | int retcode; 95 | long used_in, used_out; 96 | value res; 97 | 98 | zs->next_in = &Byte_u(srcbuf, Long_val(srcpos)); 99 | zs->avail_in = Long_val(srclen); 100 | zs->next_out = &Byte_u(dstbuf, Long_val(dstpos)); 101 | zs->avail_out = Long_val(dstlen); 102 | retcode = deflate(zs, camlzip_flush_table[Int_val(vflush)]); 103 | if (retcode < 0 && retcode != Z_BUF_ERROR) camlzip_error("Zlib.deflate", vzs); 104 | used_in = Long_val(srclen) - zs->avail_in; 105 | used_out = Long_val(dstlen) - zs->avail_out; 106 | zs->next_in = NULL; /* not required, but cleaner */ 107 | zs->next_out = NULL; /* (avoid dangling pointers into Caml heap) */ 108 | res = caml_alloc_small(3, 0); 109 | Field(res, 0) = Val_bool(retcode == Z_STREAM_END); 110 | Field(res, 1) = Val_int(used_in); 111 | Field(res, 2) = Val_int(used_out); 112 | return res; 113 | } 114 | 115 | value camlzip_deflate_bytecode(value * arg, int nargs) 116 | { 117 | return camlzip_deflate(arg[0], arg[1], arg[2], arg[3], 118 | arg[4], arg[5], arg[6], arg[7]); 119 | } 120 | 121 | value camlzip_deflateEnd(value vzs) 122 | { 123 | if (deflateEnd(ZStream_val(vzs)) != Z_OK) 124 | camlzip_error("Zlib.deflateEnd", vzs); 125 | return Val_unit; 126 | } 127 | 128 | static void camlzip_free_istream(value vzs) 129 | { 130 | inflateEnd(ZStream_val(vzs)); 131 | caml_stat_free(ZStream_val(vzs)); 132 | ZStream_val(vzs) = NULL; 133 | } 134 | 135 | static struct custom_operations camlzip_istream_ops = { 136 | "camlzip_dstream_ops", &camlzip_free_istream, NULL, NULL, NULL, NULL 137 | }; 138 | 139 | value camlzip_inflateInit(value expect_header) 140 | { 141 | value vzs = 142 | caml_alloc_custom_mem(&camlzip_istream_ops, 143 | sizeof(z_streamp), sizeof(z_stream)); 144 | /* Zlib API: The fields next_in, avail_in, zalloc, zfree and opaque 145 | must be initialized */ 146 | ZStream_val(vzs) = caml_stat_alloc(sizeof(z_stream)); 147 | ZStream_val(vzs)->zalloc = NULL; 148 | ZStream_val(vzs)->zfree = NULL; 149 | ZStream_val(vzs)->opaque = NULL; 150 | ZStream_val(vzs)->next_in = NULL; 151 | ZStream_val(vzs)->avail_in = 0; 152 | if (inflateInit2(ZStream_val(vzs), 153 | Bool_val(expect_header) ? MAX_WBITS : -MAX_WBITS) != Z_OK) 154 | camlzip_error("Zlib.inflateInit", vzs); 155 | return vzs; 156 | } 157 | 158 | value camlzip_inflate(value vzs, value srcbuf, value srcpos, value srclen, 159 | value dstbuf, value dstpos, value dstlen, 160 | value vflush) 161 | { 162 | z_stream * zs = ZStream_val(vzs); 163 | int retcode; 164 | long used_in, used_out; 165 | value res; 166 | 167 | zs->next_in = &Byte_u(srcbuf, Long_val(srcpos)); 168 | zs->avail_in = Long_val(srclen); 169 | zs->next_out = &Byte_u(dstbuf, Long_val(dstpos)); 170 | zs->avail_out = Long_val(dstlen); 171 | retcode = inflate(zs, camlzip_flush_table[Int_val(vflush)]); 172 | if ((retcode < 0 && retcode != Z_BUF_ERROR) || retcode == Z_NEED_DICT) 173 | camlzip_error("Zlib.inflate", vzs); 174 | used_in = Long_val(srclen) - zs->avail_in; 175 | used_out = Long_val(dstlen) - zs->avail_out; 176 | zs->next_in = NULL; /* not required, but cleaner */ 177 | zs->next_out = NULL; /* (avoid dangling pointers into Caml heap) */ 178 | res = caml_alloc_small(3, 0); 179 | Field(res, 0) = Val_bool(retcode == Z_STREAM_END); 180 | Field(res, 1) = Val_int(used_in); 181 | Field(res, 2) = Val_int(used_out); 182 | return res; 183 | } 184 | 185 | value camlzip_inflate_bytecode(value * arg, int nargs) 186 | { 187 | return camlzip_inflate(arg[0], arg[1], arg[2], arg[3], 188 | arg[4], arg[5], arg[6], arg[7]); 189 | } 190 | 191 | value camlzip_inflateEnd(value vzs) 192 | { 193 | if (inflateEnd(ZStream_val(vzs)) != Z_OK) 194 | camlzip_error("Zlib.inflateEnd", vzs); 195 | return Val_unit; 196 | } 197 | 198 | value camlzip_update_crc32(value crc, value buf, value pos, value len) 199 | { 200 | return caml_copy_int32(crc32((uint32_t) Int32_val(crc), 201 | &Byte_u(buf, Long_val(pos)), 202 | Long_val(len))); 203 | } 204 | 205 | --------------------------------------------------------------------------------