1 /* $Id$
2
3 Part of SWI-Prolog
4
5 Author: Jan Wielemaker
6 E-mail: wielemak@science.uva.nl
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2006, University of Amsterdam
9
10 This library is free software; you can redistribute it and/or
11 modify it under the terms of the GNU Lesser General Public
12 License as published by the Free Software Foundation; either
13 version 2.1 of the License, or (at your option) any later version.
14
15 This library is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 Lesser General Public License for more details.
19
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23 */
24
25 #define O_DEBUG 1
26 #include <SWI-Stream.h>
27 #include <SWI-Prolog.h>
28 #include <stdlib.h>
29 #include <string.h>
30 #include <assert.h>
31 #include <time.h>
32 #include <zlib.h>
33 /* Some distributions do not include this ... */
34 #ifdef HAVE_ZUTIL_H
35 #include <zutil.h>
36 #else
37 #include "zutil.h"
38 #endif
39
40 static functor_t FUNCTOR_error2; /* error(Formal, Context) */
41 static functor_t FUNCTOR_type_error2; /* type_error(Term, Expected) */
42 static functor_t FUNCTOR_domain_error2; /* domain_error(Term, Expected) */
43
44 static atom_t ATOM_format; /* format(Format) */
45 static atom_t ATOM_level; /* level(Int) */
46 static atom_t ATOM_close_parent; /* close_parent(Bool) */
47 static atom_t ATOM_gzip;
48 static atom_t ATOM_deflate;
49 static int debuglevel = 0;
50
51 #ifdef O_DEBUG
52 #define DEBUG(n, g) if ( debuglevel >= n ) g
53 #else
54 #define DEBUG(n, g) (void)0
55 #endif
56
57 /*******************************
58 * ERRORS *
59 *******************************/
60
61 static int
type_error(term_t actual,const char * expected)62 type_error(term_t actual, const char *expected)
63 { term_t ex;
64
65 if ( (ex = PL_new_term_ref()) &&
66 PL_unify_term(ex,
67 PL_FUNCTOR, FUNCTOR_error2,
68 PL_FUNCTOR, FUNCTOR_type_error2,
69 PL_CHARS, expected,
70 PL_TERM, actual,
71 PL_VARIABLE) )
72 return PL_raise_exception(ex);
73
74 return FALSE;
75 }
76
77
78 static int
domain_error(term_t actual,const char * domain)79 domain_error(term_t actual, const char *domain)
80 { term_t ex;
81
82 if ( (ex = PL_new_term_ref()) &&
83 PL_unify_term(ex,
84 PL_FUNCTOR, FUNCTOR_error2,
85 PL_FUNCTOR, FUNCTOR_domain_error2,
86 PL_CHARS, domain,
87 PL_TERM, actual,
88 PL_VARIABLE) )
89 return PL_raise_exception(ex);
90
91 return FALSE;
92 }
93
94
95 static int
instantiation_error()96 instantiation_error()
97 { term_t ex;
98
99 if ( (ex = PL_new_term_ref()) &&
100 PL_unify_term(ex,
101 PL_FUNCTOR, FUNCTOR_error2,
102 PL_CHARS, "instantiation_error",
103 PL_VARIABLE) )
104 return PL_raise_exception(ex);
105
106 return FALSE;
107 }
108
109
110 static int
get_atom_ex(term_t t,atom_t * a)111 get_atom_ex(term_t t, atom_t *a)
112 { if ( PL_get_atom(t, a) )
113 return TRUE;
114
115 return type_error(t, "atom");
116 }
117
118 static int
get_int_ex(term_t t,int * i)119 get_int_ex(term_t t, int *i)
120 { if ( PL_get_integer(t, i) )
121 return TRUE;
122
123 return type_error(t, "integer");
124 }
125
126 static int
get_bool_ex(term_t t,int * i)127 get_bool_ex(term_t t, int *i)
128 { if ( PL_get_bool(t, i) )
129 return TRUE;
130
131 return type_error(t, "boolean");
132 }
133
134
135 /*******************************
136 * TYPES *
137 *******************************/
138
139 #define BUFSIZE SIO_BUFSIZE /* raw I/O buffer */
140
141 typedef enum
142 { F_UNKNOWN = 0,
143 F_GZIP, /* gzip output */
144 F_GZIP_CRC, /* end of gzip output */
145 F_DEFLATE /* zlib data */
146 } zformat;
147
148 typedef struct z_context
149 { IOSTREAM *stream; /* Original stream */
150 IOSTREAM *zstream; /* Compressed stream (I'm handle of) */
151 int close_parent; /* close parent on close */
152 int initialized; /* did inflateInit()? */
153 zformat format; /* current format */
154 uLong crc; /* CRC check */
155 z_stream zstate; /* Zlib state */
156 } z_context;
157
158
159 static z_context*
alloc_zcontext(IOSTREAM * s)160 alloc_zcontext(IOSTREAM *s)
161 { z_context *ctx = PL_malloc(sizeof(*ctx));
162
163 memset(ctx, 0, sizeof(*ctx));
164 ctx->stream = s;
165 ctx->close_parent = TRUE;
166
167 return ctx;
168 }
169
170
171 static void
free_zcontext(z_context * ctx)172 free_zcontext(z_context *ctx)
173 { if ( ctx->stream->upstream )
174 Sset_filter(ctx->stream, NULL);
175 else
176 PL_release_stream(ctx->stream);
177
178 PL_free(ctx);
179 }
180
181
182 /*******************************
183 * GZIP HEADER *
184 *******************************/
185
186 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
187 Code based on gzio.c from the zlib source distribution.
188 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
189
190 static int gz_magic[2] = {0x1f, 0x8b}; /* gzip magic header */
191
192 /* gzip flag byte */
193 #define ASCII_FLAG 0x01 /* bit 0 set: file probably ascii text */
194 #define HEAD_CRC 0x02 /* bit 1 set: header CRC present */
195 #define EXTRA_FIELD 0x04 /* bit 2 set: extra field present */
196 #define ORIG_NAME 0x08 /* bit 3 set: original file name present */
197 #define COMMENT 0x10 /* bit 4 set: file comment present */
198 #define RESERVED 0xE0 /* bits 5..7: reserved */
199
200 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
201 gz_skip_header() parses the gzip file-header. return
202
203 * If ok: pointer to first byte following header
204 * If not a gzip file: NULL
205 * If still ok, but incomplete: GZHDR_SHORT
206 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
207
208 #define HDR_SHORT ((Bytef*)-1) /* Header is incomplete */
209 #define SKIP_STRING \
210 { while ( *in && avail > 0 ) \
211 in++, avail--; \
212 if ( avail > 0 ) \
213 in++, avail--; \
214 }
215
216 static Bytef *
gz_skip_header(z_context * ctx,Bytef * in,int avail)217 gz_skip_header(z_context *ctx, Bytef *in, int avail)
218 { int method; /* method byte */
219 int flags; /* flags byte */
220 int len;
221
222 if ( avail < 10 ) /* 2-byte magic, method, flags, */
223 return HDR_SHORT; /* time, xflags and OS code */
224
225 if ( in[0] != gz_magic[0] &&
226 in[1] != gz_magic[1] )
227 return NULL;
228 in += 2;
229
230 method = *in++;
231 flags = *in++;
232 if ( method != Z_DEFLATED || (flags & RESERVED ) != 0)
233 return NULL;
234
235 in += 6; /* Discard time, xflags and OS code */
236 avail -= 10;
237
238 if ((flags & EXTRA_FIELD) != 0)
239 { /* skip the extra field */
240 len = *in++;
241 len += (*in++)<<8;
242 len &= 0xffff;
243
244 if ( avail > len )
245 { in += len;
246 avail -= len;
247 } else
248 { return HDR_SHORT;
249 }
250 }
251 if ((flags & ORIG_NAME) != 0)
252 { /* skip the original file name */
253 SKIP_STRING
254 }
255 if ((flags & COMMENT) != 0)
256 { /* skip the .gz file comment */
257 SKIP_STRING
258 }
259 if ((flags & HEAD_CRC) != 0)
260 { /* skip the header crc */
261 in += 2;
262 avail -= 2;
263 }
264
265 if ( avail <= 0 )
266 return HDR_SHORT;
267
268 return in;
269 }
270
271
272 static int
write_ulong_lsb(IOSTREAM * s,unsigned long x)273 write_ulong_lsb(IOSTREAM *s, unsigned long x)
274 { Sputc((x) &0xff, s);
275 Sputc((x>>8) &0xff, s);
276 Sputc((x>>16)&0xff, s);
277 Sputc((x>>24)&0xff, s);
278
279 return Sferror(s) ? -1 : 0;
280 }
281
282
283 static int
write_gzip_header(z_context * ctx)284 write_gzip_header(z_context *ctx)
285 { IOSTREAM *s = ctx->stream;
286 time_t stamp = time(NULL);
287
288 Sputc(gz_magic[0], s);
289 Sputc(gz_magic[1], s);
290 Sputc(Z_DEFLATED, s); /* method */
291 Sputc(0, s); /* flags */
292 write_ulong_lsb(s, (unsigned long)stamp); /* time stamp */
293 Sputc(0, s); /* xflags */
294 Sputc(OS_CODE, s); /* OS identifier */
295
296 return Sferror(s) ? FALSE : TRUE; /* TBD: Error */
297 }
298
299
300 static int
write_gzip_footer(z_context * ctx)301 write_gzip_footer(z_context *ctx)
302 { IOSTREAM *s = ctx->stream;
303
304 write_ulong_lsb(s, ctx->crc); /* CRC32 */
305 write_ulong_lsb(s, ctx->zstate.total_in); /* Total length */
306
307 return Sferror(s) ? -1 : 0;
308 }
309
310
311 static Bytef *
get_ulong_lsb(const Bytef * in,uLong * v)312 get_ulong_lsb(const Bytef *in, uLong *v)
313 { *v = (in[0] |
314 in[1] << 8 |
315 in[2] << 16 |
316 in[3] << 24) & 0xffffffff;
317
318 return (Bytef*)in+4;
319 }
320
321
322 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
323 0: ok
324 -1: CRC/size error
325 -2: not enough data
326 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
327
328
329 static int
gz_skip_footer(z_context * ctx)330 gz_skip_footer(z_context *ctx)
331 { if ( ctx->zstate.avail_in >= 8 )
332 { uLong crc, size;
333 Bytef *in = ctx->zstate.next_in;
334
335 in = get_ulong_lsb(in, &crc);
336 in = get_ulong_lsb(in, &size);
337
338 ctx->zstate.next_in = in;
339 ctx->zstate.avail_in -= 8;
340
341 if ( crc != ctx->crc )
342 { char msg[256];
343
344 Ssprintf(msg, "CRC error (%08lx != %08lx)", crc, ctx->crc);
345 Sseterr(ctx->zstream, SIO_FERR, msg);
346 return -1;
347 }
348 if ( size != ctx->zstate.total_out )
349 { char msg[256];
350
351 Ssprintf(msg, "Size mismatch (%ld != %ld)", size, ctx->zstate.total_out);
352 Sseterr(ctx->zstream, SIO_FERR, msg);
353 return -1;
354 }
355
356 return 0;
357 }
358
359 return -2;
360 }
361
362
363 /*******************************
364 * GZ I/O *
365 *******************************/
366
367 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
368 read_more() reads more data into the zstate buffer if deflating cannot
369 do anything with the available bytes. Note that S__fillbuf() can be
370 called with data in the buffer. It moves the remaining data to the start
371 of the stream buffer and tries to read more data into the stream.
372 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
373
374 static int
read_more(z_context * ctx)375 read_more(z_context *ctx)
376 { int c;
377
378 ctx->stream->bufp = (char*)ctx->zstate.next_in;
379 ctx->stream->limitp = ctx->stream->bufp + ctx->zstate.avail_in;
380
381 if ( (c=S__fillbuf(ctx->stream)) != EOF )
382 { Sungetc(c, ctx->stream);
383 ctx->zstate.next_in = (Bytef*)ctx->stream->bufp;
384 ctx->zstate.avail_in = (long)(ctx->stream->limitp - ctx->stream->bufp);
385 ctx->stream->bufp = ctx->stream->limitp;
386
387 return 0;
388 }
389
390 return -1;
391 }
392
393
394 static ssize_t /* inflate */
zread(void * handle,char * buf,size_t size)395 zread(void *handle, char *buf, size_t size)
396 { z_context *ctx = handle;
397 int flush = Z_SYNC_FLUSH;
398 int rc;
399
400 if ( ctx->zstate.avail_in == 0 )
401 { if ( Sfeof(ctx->stream) )
402 { flush = Z_FINISH;
403 } else
404 { ctx->zstate.next_in = (Bytef*)ctx->stream->bufp;
405 ctx->zstate.avail_in = (long)(ctx->stream->limitp - ctx->stream->bufp);
406 ctx->stream->bufp = ctx->stream->limitp; /* empty buffer */
407 }
408 }
409
410 DEBUG(1, Sdprintf("Processing %d bytes\n", ctx->zstate.avail_in));
411 ctx->zstate.next_out = (Bytef*)buf;
412 ctx->zstate.avail_out = (long)size;
413
414 if ( ctx->initialized == FALSE )
415 { Bytef *p;
416
417 DEBUG(1, Sdprintf("Trying gzip header\n"));
418 if ( ctx->format == F_DEFLATE )
419 { p = NULL;
420 } else
421 { while( (p = gz_skip_header(ctx, ctx->zstate.next_in,
422 ctx->zstate.avail_in)) == HDR_SHORT )
423 { int rc;
424
425 if ( (rc=read_more(ctx)) < 0 )
426 return -1;
427 }
428 }
429
430 if ( p )
431 { long m = (int)(p - ctx->zstate.next_in);
432
433 ctx->format = F_GZIP;
434 DEBUG(1, Sdprintf("Skipped gzip header (%d bytes)\n", m));
435 ctx->zstate.next_in = p;
436 ctx->zstate.avail_in -= m;
437
438 /* init without header */
439 switch(inflateInit2(&ctx->zstate, -MAX_WBITS))
440 { case Z_OK:
441 ctx->initialized = TRUE;
442 ctx->crc = crc32(0L, Z_NULL, 0);
443 DEBUG(1, Sdprintf("inflateInit2(): Z_OK\n"));
444 break;
445 case Z_MEM_ERROR: /* no memory */
446 case Z_VERSION_ERROR: /* bad library version */
447 PL_warning("ERROR: TBD");
448 return -1;
449 default:
450 assert(0);
451 return -1;
452 }
453 } else
454 { switch(inflateInit(&ctx->zstate))
455 { case Z_OK:
456 ctx->format = F_DEFLATE;
457 ctx->initialized = TRUE;
458 DEBUG(1, Sdprintf("inflateInit(): Z_OK\n"));
459 break;
460 case Z_MEM_ERROR: /* no memory */
461 case Z_VERSION_ERROR: /* bad library version */
462 PL_warning("ERROR: TBD");
463 return -1;
464 default:
465 assert(0);
466 return -1;
467 }
468 }
469 } else if ( ctx->format == F_GZIP_CRC )
470 { int rc;
471
472 while( (rc=gz_skip_footer(ctx)) == -2 )
473 { int rc2;
474
475 if ( (rc2=read_more(ctx)) < 0 )
476 return -1;
477 }
478
479 if ( rc == 0 )
480 { int avail = ctx->zstate.avail_in;
481
482 /* copy back unprocessed bytes */
483 DEBUG(1, Sdprintf("GZIP footer ok; copying %d bytes back\n", avail));
484 memmove(ctx->stream->buffer, ctx->zstate.next_in, avail);
485 ctx->stream->bufp = ctx->stream->buffer;
486 ctx->stream->limitp = ctx->stream->bufp + avail;
487
488 return 0; /* EOF */
489 } else
490 { DEBUG(1, Sdprintf("GZIP CRC/length error\n"));
491 return -1;
492 }
493 }
494
495 switch((rc=inflate(&ctx->zstate, Z_NO_FLUSH)))
496 { case Z_OK:
497 case Z_STREAM_END:
498 { long n = (long)(size - ctx->zstate.avail_out);
499
500 if ( ctx->format == F_GZIP && n > 0 )
501 ctx->crc = crc32(ctx->crc, (Bytef*)buf, n);
502
503 if ( rc == Z_STREAM_END )
504 { DEBUG(1, Sdprintf("Z_STREAM_END: %d bytes\n", n));
505
506 if ( ctx->format == F_GZIP )
507 ctx->format = F_GZIP_CRC;
508 } else
509 { DEBUG(1, Sdprintf("inflate(): Z_OK: %d bytes\n", n));
510 }
511
512 return n;
513 }
514 case Z_NEED_DICT:
515 DEBUG(1, Sdprintf("Z_NEED_DICT\n"));
516 break;
517 case Z_DATA_ERROR:
518 DEBUG(1, Sdprintf("Z_DATA_ERROR\n"));
519 break;
520 case Z_STREAM_ERROR:
521 DEBUG(1, Sdprintf("Z_STREAM_ERROR\n"));
522 break;
523 case Z_MEM_ERROR:
524 DEBUG(1, Sdprintf("Z_MEM_ERROR\n"));
525 break;
526 case Z_BUF_ERROR:
527 DEBUG(1, Sdprintf("Z_BUF_ERROR\n"));
528 break;
529 default:
530 DEBUG(1, Sdprintf("Inflate error: %d\n", rc));
531 }
532 if ( ctx->zstate.msg )
533 Sdprintf("ERROR: zread(): %s\n", ctx->zstate.msg);
534 return -1;
535 }
536
537
538 static ssize_t /* deflate */
zwrite4(void * handle,char * buf,size_t size,int flush)539 zwrite4(void *handle, char *buf, size_t size, int flush)
540 { z_context *ctx = handle;
541 Bytef buffer[SIO_BUFSIZE];
542 int rc;
543 int loops = 0;
544
545 ctx->zstate.next_in = (Bytef*)buf;
546 ctx->zstate.avail_in = (long)size;
547 if ( ctx->format == F_GZIP && size > 0 )
548 ctx->crc = crc32(ctx->crc, ctx->zstate.next_in, ctx->zstate.avail_in);
549
550 DEBUG(1, Sdprintf("Compressing %d bytes\n", ctx->zstate.avail_in));
551 do
552 { loops++;
553 ctx->zstate.next_out = buffer;
554 ctx->zstate.avail_out = sizeof(buffer);
555
556 switch( (rc = deflate(&ctx->zstate, flush)) )
557 { case Z_OK:
558 case Z_STREAM_END:
559 { size_t n = sizeof(buffer) - ctx->zstate.avail_out;
560
561 DEBUG(1, Sdprintf("Compressed (%s) to %d bytes; left %d\n",
562 rc == Z_OK ? "Z_OK" : "Z_STREAM_END",
563 n, ctx->zstate.avail_in));
564
565 if ( Sfwrite(buffer, 1, n, ctx->stream) != n )
566 return -1;
567
568 break;
569 }
570 case Z_BUF_ERROR:
571 DEBUG(1, Sdprintf("zwrite4(): Z_BUF_ERROR\n"));
572 break;
573 case Z_STREAM_ERROR:
574 default:
575 Sdprintf("ERROR: zwrite(): %s\n", ctx->zstate.msg);
576 return -1;
577 }
578 } while ( ctx->zstate.avail_in > 0 ||
579 (flush != Z_NO_FLUSH && rc == Z_OK) );
580
581 if ( flush != Z_NO_FLUSH && Sflush(ctx->stream) < 0 )
582 return -1;
583
584 return size;
585 }
586
587
588 static ssize_t /* deflate */
zwrite(void * handle,char * buf,size_t size)589 zwrite(void *handle, char *buf, size_t size)
590 { return zwrite4(handle, buf, size, Z_NO_FLUSH);
591 }
592
593
594 static int
zcontrol(void * handle,int op,void * data)595 zcontrol(void *handle, int op, void *data)
596 { z_context *ctx = handle;
597
598 switch(op)
599 { case SIO_FLUSHOUTPUT:
600 DEBUG(1, Sdprintf("Flushing output\n"));
601 return (int)zwrite4(handle, NULL, 0, Z_SYNC_FLUSH);
602 case SIO_SETENCODING:
603 return 0; /* allow switching encoding */
604 default:
605 if ( ctx->stream->functions->control )
606 return (*ctx->stream->functions->control)(ctx->stream->handle, op, data);
607 return -1;
608 }
609 }
610
611
612 static int
zclose(void * handle)613 zclose(void *handle)
614 { z_context *ctx = handle;
615 ssize_t rc;
616
617 DEBUG(1, Sdprintf("zclose() ...\n"));
618
619 if ( (ctx->stream->flags & SIO_INPUT) )
620 { rc = inflateEnd(&ctx->zstate);
621 } else
622 { rc = zwrite4(handle, NULL, 0, Z_FINISH); /* flush */
623 if ( rc == 0 && ctx->format == F_GZIP )
624 rc = write_gzip_footer(ctx);
625 if ( rc == 0 )
626 rc = deflateEnd(&ctx->zstate);
627 else
628 deflateEnd(&ctx->zstate);
629 }
630
631 switch(rc)
632 { case Z_OK:
633 DEBUG(1, Sdprintf("%s(): Z_OK\n",
634 (ctx->stream->flags & SIO_INPUT) ? "inflateEnd"
635 : "deflateEnd"));
636 if ( ctx->close_parent )
637 { IOSTREAM *parent = ctx->stream;
638 free_zcontext(ctx);
639 return Sclose(parent);
640 } else
641 { free_zcontext(ctx);
642 return 0;
643 }
644 case Z_STREAM_ERROR: /* inconsistent state */
645 case Z_DATA_ERROR: /* premature end */
646 default:
647 if ( ctx->close_parent )
648 { IOSTREAM *parent = ctx->stream;
649 free_zcontext(ctx);
650 Sclose(parent);
651 return -1;
652 }
653
654 free_zcontext(ctx);
655 return -1;
656 }
657 }
658
659
660 static IOFUNCTIONS zfunctions =
661 { zread,
662 zwrite,
663 NULL, /* seek */
664 zclose,
665 zcontrol, /* zcontrol */
666 NULL, /* seek64 */
667 };
668
669
670 /*******************************
671 * PROLOG CONNECTION *
672 *******************************/
673
674 #define COPY_FLAGS (SIO_INPUT|SIO_OUTPUT| \
675 SIO_TEXT| \
676 SIO_REPXML|SIO_REPPL|\
677 SIO_RECORDPOS)
678
679 static foreign_t
pl_zopen(term_t org,term_t new,term_t options)680 pl_zopen(term_t org, term_t new, term_t options)
681 { term_t tail = PL_copy_term_ref(options);
682 term_t head = PL_new_term_ref();
683 z_context *ctx;
684 zformat fmt = F_UNKNOWN;
685 int level = Z_DEFAULT_COMPRESSION;
686 IOSTREAM *s, *s2;
687 int close_parent = TRUE;
688
689 while(PL_get_list(tail, head, tail))
690 { atom_t name;
691 int arity;
692 term_t arg = PL_new_term_ref();
693
694 if ( !PL_get_name_arity(head, &name, &arity) || arity != 1 )
695 return type_error(head, "option");
696 _PL_get_arg(1, head, arg);
697
698 if ( name == ATOM_format )
699 { atom_t a;
700
701 if ( !get_atom_ex(arg, &a) )
702 return FALSE;
703 if ( a == ATOM_gzip )
704 fmt = F_GZIP;
705 else if ( a == ATOM_deflate )
706 fmt = F_DEFLATE;
707 else
708 return domain_error(arg, "compression_format");
709 } else if ( name == ATOM_level )
710 { if ( !get_int_ex(arg, &level) )
711 return FALSE;
712 if ( level < 0 || level > 9 )
713 return domain_error(arg, "compression_level");
714 } else if ( name == ATOM_close_parent )
715 { if ( !get_bool_ex(arg, &close_parent) )
716 return FALSE;
717 }
718 }
719 if ( !PL_get_nil(tail) )
720 return type_error(tail, "list");
721
722 if ( !PL_get_stream_handle(org, &s) )
723 return FALSE; /* Error */
724 ctx = alloc_zcontext(s);
725 ctx->close_parent = close_parent;
726 ctx->format = fmt;
727 if ( (s->flags & SIO_OUTPUT) )
728 { int rc;
729
730 if ( fmt == F_GZIP )
731 { if ( write_gzip_header(ctx) < 0 )
732 { free_zcontext(ctx);
733 return FALSE;
734 }
735 rc = deflateInit2(&ctx->zstate, level, Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, 0);
736 } else
737 { rc = deflateInit(&ctx->zstate, level);
738 }
739
740 if ( rc != Z_OK )
741 { free_zcontext(ctx);
742 return FALSE; /* TBD: Error */
743 }
744 }
745
746 if ( !(s2 = Snew(ctx,
747 (s->flags©_FLAGS)|SIO_FBUF,
748 &zfunctions)) )
749 { free_zcontext(ctx); /* no memory */
750
751 return FALSE;
752 }
753
754 s2->encoding = s->encoding;
755 ctx->zstream = s2;
756 Sset_filter(s, s2);
757 PL_release_stream(s);
758 if ( PL_unify_stream(new, s2) )
759 { return TRUE;
760 } else
761 { ctx->close_parent = FALSE;
762 Sclose(s2);
763 return instantiation_error();
764 }
765 }
766
767
768 #ifdef O_DEBUG
769 static foreign_t
zdebug(term_t level)770 zdebug(term_t level)
771 { return PL_get_integer(level, &debuglevel);
772 }
773 #endif
774
775 /*******************************
776 * INSTALL *
777 *******************************/
778
779 #define MKFUNCTOR(name, arity) PL_new_functor(PL_new_atom(name), arity)
780
781 install_t
install_zlib4pl()782 install_zlib4pl()
783 { FUNCTOR_error2 = MKFUNCTOR("error", 2);
784 FUNCTOR_type_error2 = MKFUNCTOR("type_error", 2);
785 FUNCTOR_domain_error2 = MKFUNCTOR("domain_error", 2);
786
787 ATOM_format = PL_new_atom("format");
788 ATOM_level = PL_new_atom("level");
789 ATOM_close_parent = PL_new_atom("close_parent");
790 ATOM_gzip = PL_new_atom("gzip");
791 ATOM_deflate = PL_new_atom("deflate");
792
793 PL_register_foreign("zopen", 3, pl_zopen, 0);
794 #ifdef O_DEBUG
795 PL_register_foreign("zdebug", 1, zdebug, 0);
796 #endif
797 }
798