Subversion Repositories

?revision_form?Rev ?revision_input??revision_submit??revision_endform?

Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
1 magnus 1
package DebPool::Gzip;
2
 
3
###
4
#
5
# DebPool::Gzip - Module for handling Gzip interactions
6
#
7
# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
8
# 
9
# Redistribution and use in source and binary forms, with or without
10
# modification, are permitted provided that the following conditions
11
# are met:
12
# 1. Redistributions of source code must retain the above copyright
13
#    notice, this list of conditions and the following disclaimer.
14
# 2. Redistributions in binary form must reproduce the above copyright
15
#    notice, this list of conditions and the following disclaimer in the
16
#    documentation and/or other materials provided with the distribution.
17
# 3. Neither the name of the Author nor the names of any contributors
18
#    may be used to endorse or promote products derived from this software
19
#    without specific prior written permission.
20
# 
21
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
22
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
25
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
27
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
30
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
31
# SUCH DAMAGE.
32
#
33
# $Id: Gzip.pm 27 2004-11-07 03:06:59Z joel $
34
#
35
###
36
 
37
# We use 'our', so we must have at least Perl 5.6
38
 
39
require 5.006_000;
40
 
41
# Always good ideas.
42
 
43
use strict;
44
use warnings;
45
 
46
use POSIX; # WEXITSTATUS
47
use File::Temp qw(tempfile);
48
 
49
# Needed for open2()
50
 
51
use Fcntl;
52
use IPC::Open2;
53
 
54
### Module setup
55
 
56
BEGIN {
57
    use Exporter ();
58
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
59
 
60
    # Version checking
61
    $VERSION = '0.1.5';
62
 
63
    @ISA = qw(Exporter);
64
 
65
    @EXPORT = qw(
66
    );
67
 
68
    @EXPORT_OK = qw(
69
        &Gzip_File
70
    );
71
 
72
    %EXPORT_TAGS = (
73
        'functions' => [qw(&Gzip_File)],
74
        'vars' => [qw()],
75
    );
76
}
77
 
78
### Exported package globals
79
 
80
### Non-exported package globals
81
 
82
# Thread-safe? What's that? Package global error value. We don't export
83
# this directly, because it would conflict with other modules.
84
 
85
our($Error);
86
 
87
### File lexicals
88
 
89
# None
90
 
91
### Constant functions
92
 
93
# None
94
 
95
### Meaningful functions
96
 
97
# Gzip_File($file)
98
#
99
# Generates a gzipped version of $file, and returns the filename. Returns
100
# undef (and sets $Error) on failure.
101
 
102
sub Gzip_File {
103
    use DebPool::Logging qw(:functions :facility :level);
104
 
105
    my($file) = @_;
106
 
107
    # Open a secure tempfile to write the compressed data into
108
 
109
    my($tmpfile_handle, $tmpfile_name) = tempfile();
110
 
111
    # Open the source file so that we have it available.
112
 
113
    if (!open(SOURCE, '<', $file)) {
114
        $Error = "Couldn't open source file '$file': $!";
115
        return undef;
116
    }
117
 
118
    # We are go for main engine start
119
 
120
    my(@args) = ('--best', '--force', '--stdout');
121
 
122
    my($gzip_pid) = open2(*GZIP_IN, *GZIP_OUT, '/bin/gzip', @args);
123
 
124
    my($child_pid);
125
    if ($child_pid = fork) { # In the parent
126
        # Send all the data to Gzip;
127
 
128
        close(GZIP_IN);
129
        close($tmpfile_handle);
130
 
131
        print GZIP_OUT <SOURCE>;
132
        close(GZIP_OUT);
133
        close(SOURCE);
134
 
135
        waitpid($child_pid, 0);
136
    } else { # In the child - we hope
137
        if (!defined($child_pid)) {
138
            die "Couldn't fork: $!\n";
139
        }
140
 
141
        # Read back the results, and print them into the tempfile.
142
 
143
        close(GZIP_OUT);
144
        close(SOURCE);
145
 
146
        print $tmpfile_handle <GZIP_IN>;
147
        close(GZIP_IN);
148
        close($tmpfile_handle);
149
 
150
        exit(0);
151
    }
152
 
153
    # And we're done
154
 
155
    return $tmpfile_name;
156
}
157
 
158
END {}
159
 
160
1;
161
 
162
__END__
163
 
164
# vim:set tabstop=4 expandtab: