|
1 # Copyright (c) 2000 Ned Konz. All rights reserved. This program is free |
|
2 # software; you can redistribute it and/or modify it under the same terms |
|
3 # as Perl itself. |
|
4 |
|
5 # $Revision: 1.5 $ |
|
6 package Archive::Zip::Archive; |
|
7 use File::Find (); |
|
8 use Archive::Zip qw(:ERROR_CODES :UTILITY_METHODS); |
|
9 |
|
10 =head1 NAME |
|
11 |
|
12 Archive::Zip::Tree -- methods for adding/extracting trees using Archive::Zip |
|
13 |
|
14 =head1 SYNOPSIS |
|
15 |
|
16 use Archive::Zip; |
|
17 use Archive::Zip::Tree; |
|
18 my $zip = Archive::Zip->new(); |
|
19 # add all readable files and directories below . as xyz/* |
|
20 $zip->addTree( '.', 'xyz' ); |
|
21 # add all readable plain files below /abc as /def/* |
|
22 $zip->addTree( '/abc', '/def', sub { -f && -r } ); |
|
23 # add all .c files below /tmp as stuff/* |
|
24 $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' ); |
|
25 # add all .o files below /tmp as stuff/* if they aren't writable |
|
26 $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } ); |
|
27 # and write them into a file |
|
28 $zip->writeToFile('xxx.zip'); |
|
29 |
|
30 # now extract the same files into /tmpx |
|
31 $zip->extractTree( 'stuff', '/tmpx' ); |
|
32 |
|
33 =head1 METHODS |
|
34 |
|
35 =over 4 |
|
36 |
|
37 =item $zip->addTree( $root, $dest [,$pred] ) |
|
38 |
|
39 $root is the root of the tree of files and directories to be added |
|
40 |
|
41 $dest is the name for the root in the zip file (undef or blank means to use |
|
42 relative pathnames) |
|
43 |
|
44 C<$pred> is an optional subroutine reference to select files: it is passed the |
|
45 name of the prospective file or directory using C<$_>, |
|
46 and if it returns true, the file or |
|
47 directory will be included. The default is to add all readable files and |
|
48 directories. |
|
49 |
|
50 For instance, using |
|
51 |
|
52 my $pred = sub { /\.txt/ }; |
|
53 $zip->addTree( '.', '.', $pred ); |
|
54 |
|
55 will add all the .txt files in and below the current directory, |
|
56 using relative names, and making the names identical in the zipfile: |
|
57 |
|
58 original name zip member name |
|
59 ./xyz xyz |
|
60 ./a/ a/ |
|
61 ./a/b a/b |
|
62 |
|
63 To use absolute pathnames, just pass them in: |
|
64 |
|
65 $zip->addTree( '/a/b', '/a/b' ); |
|
66 |
|
67 original name zip member name |
|
68 /a/ /a/ |
|
69 /a/b /a/b |
|
70 |
|
71 To translate relative to absolute pathnames, just pass them in: |
|
72 |
|
73 $zip->addTree( '.', '/c/d' ); |
|
74 |
|
75 original name zip member name |
|
76 ./xyz /c/d/xyz |
|
77 ./a/ /c/d/a/ |
|
78 ./a/b /c/d/a/b |
|
79 |
|
80 To translate absolute to relative pathnames, just pass them in: |
|
81 |
|
82 $zip->addTree( '/c/d', 'a' ); |
|
83 |
|
84 original name zip member name |
|
85 /c/d/xyz a/xyz |
|
86 /c/d/a/ a/a/ |
|
87 /c/d/a/b a/a/b |
|
88 |
|
89 Returns AZ_OK on success. |
|
90 |
|
91 Note that this will not follow symbolic links to directories. |
|
92 |
|
93 Note also that this does not check for the validity of filenames. |
|
94 |
|
95 =back |
|
96 |
|
97 =cut |
|
98 |
|
99 sub addTree |
|
100 { |
|
101 my $self = shift; |
|
102 my $root = shift or return _error("root arg missing in call to addTree()"); |
|
103 my $dest = shift || ''; |
|
104 my $pred = shift || sub { -r }; |
|
105 $root =~ s{\\}{/}g; # normalize backslashes in case user is misguided |
|
106 $root =~ s{([^/])$}{$1/}; # append slash if necessary |
|
107 $dest =~ s{([^/])$}{$1/} if $dest; # append slash if necessary |
|
108 my @files; |
|
109 File::Find::find( sub { push( @files, $File::Find::name ) }, $root ); |
|
110 @files = grep { &$pred } @files; # pass arg via local $_ |
|
111 foreach my $fileName ( @files ) |
|
112 { |
|
113 ( my $archiveName = $fileName ) =~ s{^\Q$root}{$dest}; |
|
114 $archiveName =~ s{^\./}{}; |
|
115 next if $archiveName =~ m{^\.?/?$}; # skip current dir |
|
116 my $member = ( -d $fileName ) |
|
117 ? $self->addDirectory( $fileName, $archiveName ) |
|
118 : $self->addFile( $fileName, $archiveName ); |
|
119 return _error( "add $fileName failed in addTree()" ) if !$member; |
|
120 } |
|
121 return AZ_OK; |
|
122 } |
|
123 |
|
124 =over 4 |
|
125 |
|
126 =item $zip->addTreeMatching( $root, $dest, $pattern [,$pred] ) |
|
127 |
|
128 $root is the root of the tree of files and directories to be added |
|
129 |
|
130 $dest is the name for the root in the zip file (undef means to use relative |
|
131 pathnames) |
|
132 |
|
133 $pattern is a (non-anchored) regular expression for filenames to match |
|
134 |
|
135 $pred is an optional subroutine reference to select files: it is passed the |
|
136 name of the prospective file or directory in C<$_>, |
|
137 and if it returns true, the file or |
|
138 directory will be included. The default is to add all readable files and |
|
139 directories. |
|
140 |
|
141 To add all files in and below the current dirctory |
|
142 whose names end in C<.pl>, and make them extract into a subdirectory |
|
143 named C<xyz>, do this: |
|
144 |
|
145 $zip->addTreeMatching( '.', 'xyz', '\.pl$' ) |
|
146 |
|
147 To add all I<writable> files in and below the dirctory named C</abc> |
|
148 whose names end in C<.pl>, and make them extract into a subdirectory |
|
149 named C<xyz>, do this: |
|
150 |
|
151 $zip->addTreeMatching( '/abc', 'xyz', '\.pl$', sub { -w } ) |
|
152 |
|
153 Returns AZ_OK on success. |
|
154 |
|
155 Note that this will not follow symbolic links to directories. |
|
156 |
|
157 =back |
|
158 |
|
159 =cut |
|
160 |
|
161 sub addTreeMatching |
|
162 { |
|
163 my $self = shift; |
|
164 my $root = shift |
|
165 or return _error("root arg missing in call to addTreeMatching()"); |
|
166 my $dest = shift || ''; |
|
167 my $pattern = shift |
|
168 or return _error("pattern missing in call to addTreeMatching()"); |
|
169 my $pred = shift || sub { -r }; |
|
170 my $matcher = sub { m{$pattern} && &$pred }; |
|
171 return $self->addTree( $root, $dest, $matcher ); |
|
172 } |
|
173 |
|
174 =over 4 |
|
175 |
|
176 =item $zip->extractTree( $root, $dest ) |
|
177 |
|
178 Extracts all the members below a given root. Will |
|
179 translate that root to a given dest pathname. |
|
180 |
|
181 For instance, |
|
182 |
|
183 $zip->extractTree( '/a/', 'd/e/' ); |
|
184 |
|
185 when applied to a zip containing the files: |
|
186 /a/x /a/b/c /d/e |
|
187 |
|
188 will extract: |
|
189 /a/x to d/e/x |
|
190 /a/b/c to d/e/b/c |
|
191 |
|
192 and ignore /d/e |
|
193 |
|
194 =back |
|
195 |
|
196 =cut |
|
197 |
|
198 sub extractTree |
|
199 { |
|
200 my $self = shift(); |
|
201 my $root = shift(); |
|
202 return _error("root arg missing in call to extractTree()") |
|
203 unless defined($root); |
|
204 my $dest = shift || '.'; |
|
205 $root =~ s{\\}{/}g; # normalize backslashes in case user is misguided |
|
206 $root =~ s{([^/])$}{$1/}; # append slash if necessary |
|
207 my @members = $self->membersMatching( "^$root" ); |
|
208 foreach my $member ( @members ) |
|
209 { |
|
210 my $fileName = $member->fileName(); |
|
211 $fileName =~ s{$root}{$dest}; |
|
212 my $status = $member->extractToFileNamed( $fileName ); |
|
213 return $status if $status != AZ_OK; |
|
214 } |
|
215 return AZ_OK; |
|
216 } |
|
217 |
|
218 1; |
|
219 __END__ |
|
220 |
|
221 =head1 AUTHOR |
|
222 |
|
223 Ned Konz, perl@bike-nomad.com |
|
224 |
|
225 =head1 COPYRIGHT |
|
226 |
|
227 Copyright (c) 2000 Ned Konz. All rights reserved. This program is free |
|
228 software; you can redistribute it and/or modify it under the same terms |
|
229 as Perl itself. |
|
230 |
|
231 =head1 SEE ALSO |
|
232 |
|
233 L<Compress::Zlib> |
|
234 L<Archive::Zip> |
|
235 |
|
236 =cut |
|
237 |
|
238 # vim: ts=4 sw=4 columns=80 |