line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# -*- perl -*- |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# $Id: Export.pm,v 1.10 2005/02/16 23:59:10 eserte Exp $ |
5
|
|
|
|
|
|
|
# Author: Slaven Rezic |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# Copyright (C) 2001 Online Office Berlin. All rights reserved. |
8
|
|
|
|
|
|
|
# Copyright (C) 2002 Slaven Rezic. |
9
|
|
|
|
|
|
|
# This is free software; you can redistribute it and/or modify it under the |
10
|
|
|
|
|
|
|
# terms of the GNU General Public License, see the file COPYING. |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# |
13
|
|
|
|
|
|
|
# Mail: slaven@rezic.de |
14
|
|
|
|
|
|
|
# WWW: http://we-framework.sourceforge.net |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
package WE::Export; |
18
|
|
|
|
|
|
|
|
19
|
1
|
|
|
1
|
|
1176
|
use base qw/Class::Accessor/; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
75
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
__PACKAGE__->mk_accessors(qw/Root Tmpdir Archive Verbose Force |
22
|
|
|
|
|
|
|
_DirMode _FileMode/); |
23
|
|
|
|
|
|
|
|
24
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
24
|
|
25
|
1
|
|
|
1
|
|
4
|
use vars qw($VERSION); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
65
|
|
26
|
|
|
|
|
|
|
$VERSION = sprintf("%d.%02d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/); |
27
|
|
|
|
|
|
|
|
28
|
1
|
|
|
1
|
|
525
|
use WE::Util::Functions qw(_save_pwd is_in_path file_name_is_absolute); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
69
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 NAME |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
WE::Export - export a WE::DB database |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=head1 SYNOPSIS |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
use WE::Export; |
37
|
|
|
|
|
|
|
my $r = new WE::DB ...; |
38
|
|
|
|
|
|
|
my $ex = new WE::Export $r; |
39
|
|
|
|
|
|
|
$ex->export_all; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=head1 DESCRIPTION |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
This module provides export and import methods for the WE::DB database. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=cut |
46
|
|
|
|
|
|
|
|
47
|
1
|
|
|
1
|
|
6
|
use File::Path; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
62
|
|
48
|
1
|
|
|
1
|
|
5
|
use File::Basename; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
62
|
|
49
|
1
|
|
|
1
|
|
5
|
use File::Find; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
42
|
|
50
|
1
|
|
|
1
|
|
789
|
use File::Copy; |
|
1
|
|
|
|
|
2283
|
|
|
1
|
|
|
|
|
51
|
|
51
|
1
|
|
|
1
|
|
998
|
use Data::Dumper 2.101; # older versions are buggy |
|
1
|
|
|
|
|
5930
|
|
|
1
|
|
|
|
|
61
|
|
52
|
1
|
|
|
1
|
|
376
|
use DB_File; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
use Fcntl; |
54
|
|
|
|
|
|
|
use Safe; |
55
|
|
|
|
|
|
|
use Cwd; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
use vars qw(%db_filename); |
58
|
|
|
|
|
|
|
%db_filename = ( |
59
|
|
|
|
|
|
|
ObjDB => 'objdb', |
60
|
|
|
|
|
|
|
UserDB => 'userdb', |
61
|
|
|
|
|
|
|
OnlineUserDB => 'onlinedb', |
62
|
|
|
|
|
|
|
NameDB => 'name', |
63
|
|
|
|
|
|
|
); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# Should be something which is recognized by the "*" glob: |
66
|
|
|
|
|
|
|
use constant MTREE_FILE => "mtree"; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=head2 CONSTRUCTOR new |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
Called as C. Create a new WE::Export object |
71
|
|
|
|
|
|
|
for the given database C<$rootdb>. Additional arguments (as dashed |
72
|
|
|
|
|
|
|
key-value pairs) will be passed to the object. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=cut |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub new { |
77
|
|
|
|
|
|
|
my($pkg, $rootdb, %args) = @_; |
78
|
|
|
|
|
|
|
my $self = { }; |
79
|
|
|
|
|
|
|
bless $self, $pkg; |
80
|
|
|
|
|
|
|
$self->_DirMode(undef); |
81
|
|
|
|
|
|
|
$self->_FileMode(undef); |
82
|
|
|
|
|
|
|
while(my($k,$v) = each %args) { |
83
|
|
|
|
|
|
|
die "Option does not start with a dash: $k" if $k !~ /^-/; |
84
|
|
|
|
|
|
|
$self->{ucfirst(substr($k,1))} = $v; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
$self->Root($rootdb); |
87
|
|
|
|
|
|
|
$self; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
=head2 METHODS |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=over 4 |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=item export_db |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
Create data dumper files of the metadata databases and store them into |
97
|
|
|
|
|
|
|
the directory specified by the C member. Data::Dumper files |
98
|
|
|
|
|
|
|
are created because most DBM file formats are incompatible between |
99
|
|
|
|
|
|
|
various systems. |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=cut |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub export_db { |
104
|
|
|
|
|
|
|
my $self = shift; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
my $rootdb = $self->Root; |
107
|
|
|
|
|
|
|
my $objdb = $rootdb->ObjDB; |
108
|
|
|
|
|
|
|
my $objdbfile = $objdb->DBFile; |
109
|
|
|
|
|
|
|
my $objdump; |
110
|
|
|
|
|
|
|
my $dd; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# Note: do not use connect(), because we want the plain data, not the |
113
|
|
|
|
|
|
|
# MLDBM cooked data |
114
|
|
|
|
|
|
|
tie my %db, 'DB_File', $objdbfile, O_RDONLY, 0644 |
115
|
|
|
|
|
|
|
or die "Can't tie to $objdbfile: $!"; |
116
|
|
|
|
|
|
|
$dd = Data::Dumper->new([\%db],['ObjDB']); |
117
|
|
|
|
|
|
|
$dd->Indent(0); |
118
|
|
|
|
|
|
|
#$dd->Purity(1); # XXX |
119
|
|
|
|
|
|
|
$objdump = $dd->Dump; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
if (!defined $objdump) { |
122
|
|
|
|
|
|
|
die "Dump of object database is empty!"; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# XXX this will not work if UserDB will switch to MLDBM! |
126
|
|
|
|
|
|
|
my $userdb = $rootdb->UserDB; |
127
|
|
|
|
|
|
|
my $userdump; |
128
|
|
|
|
|
|
|
$dd = Data::Dumper->new([$userdb->{DB}], ['UserDB']); |
129
|
|
|
|
|
|
|
$dd->Indent(0); |
130
|
|
|
|
|
|
|
#$dd->Purity(1); # XXX |
131
|
|
|
|
|
|
|
$userdump = $dd->Dump; |
132
|
|
|
|
|
|
|
if (!defined $userdump) { |
133
|
|
|
|
|
|
|
die "Dump of user database is empty!"; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
my $onlineuserdb = $rootdb->OnlineUserDB; |
137
|
|
|
|
|
|
|
my $onlineuserdump; |
138
|
|
|
|
|
|
|
$dd = Data::Dumper->new([$onlineuserdb->{DB}], ['OnlineUserDB']); |
139
|
|
|
|
|
|
|
$dd->Indent(0); |
140
|
|
|
|
|
|
|
#$dd->Purity(1); # XXX |
141
|
|
|
|
|
|
|
$onlineuserdump = $dd->Dump; |
142
|
|
|
|
|
|
|
if (!defined $onlineuserdump) { |
143
|
|
|
|
|
|
|
die "Dump of online user database is empty!"; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
my $namedb = $rootdb->NameDB; |
147
|
|
|
|
|
|
|
my $namedump; |
148
|
|
|
|
|
|
|
$dd = Data::Dumper->new([$namedb->{DB}], ['NameDB']); |
149
|
|
|
|
|
|
|
$dd->Indent(0); |
150
|
|
|
|
|
|
|
#$dd->Purity(1); # XXX |
151
|
|
|
|
|
|
|
$namedump = $dd->Dump; |
152
|
|
|
|
|
|
|
if (!defined $namedump) { |
153
|
|
|
|
|
|
|
die "Dump of name database is empty!"; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
my $objdboutfile = $self->Tmpdir . "/$db_filename{ObjDB}.db.dd"; |
157
|
|
|
|
|
|
|
my $userdboutfile = $self->Tmpdir . "/$db_filename{UserDB}.db.dd"; |
158
|
|
|
|
|
|
|
my $onlineuserdboutfile = $self->Tmpdir . "/$db_filename{OnlineUserDB}.db.dd"; |
159
|
|
|
|
|
|
|
my $namedboutfile = $self->Tmpdir . "/$db_filename{NameDB}.db.dd"; |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
open(DB, "> $objdboutfile") or die "Can't create $objdboutfile: $!"; |
162
|
|
|
|
|
|
|
print DB $objdump; |
163
|
|
|
|
|
|
|
close DB; |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
open(DB, "> $userdboutfile") or die "Can't create $userdboutfile: $!"; |
166
|
|
|
|
|
|
|
print DB $userdump; |
167
|
|
|
|
|
|
|
close DB; |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
open(DB, "> $onlineuserdboutfile") or die "Can't create $onlineuserdboutfile: $!"; |
170
|
|
|
|
|
|
|
print DB $onlineuserdump; |
171
|
|
|
|
|
|
|
close DB; |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
open(DB, "> $namedboutfile") or die "Can't create $namedboutfile: $!"; |
174
|
|
|
|
|
|
|
print DB $namedump; |
175
|
|
|
|
|
|
|
close DB; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
1; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
=item export_content |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
Copy the content files to the C subdirectory of the directory |
183
|
|
|
|
|
|
|
specified by the C member. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=cut |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
sub export_content { |
188
|
|
|
|
|
|
|
my $self = shift; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
my $rootdb = $self->Root; |
191
|
|
|
|
|
|
|
my $contentdb = $rootdb->ContentDB; |
192
|
|
|
|
|
|
|
my $directory = $contentdb->Directory; |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
my $contentdir = $self->Tmpdir . "/content"; |
195
|
|
|
|
|
|
|
mkdir $contentdir, 0755; |
196
|
|
|
|
|
|
|
if (!-d $contentdir) { |
197
|
|
|
|
|
|
|
die "Can't create $contentdir: $!"; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
my @directories; |
201
|
|
|
|
|
|
|
my @files; |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
my $wanted = sub { |
204
|
|
|
|
|
|
|
# unwanted directories |
205
|
|
|
|
|
|
|
if ($_ =~ /^(RCS|CVS|\.svn|\.AppleDouble)$/) { |
206
|
|
|
|
|
|
|
$File::Find::prune = 1; |
207
|
|
|
|
|
|
|
return; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
# unwanted files |
210
|
|
|
|
|
|
|
if ($_ =~ /~$/) { |
211
|
|
|
|
|
|
|
return; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
if (-f $_) { |
214
|
|
|
|
|
|
|
push @files, $File::Find::name; |
215
|
|
|
|
|
|
|
} elsif (-d $_) { |
216
|
|
|
|
|
|
|
push @directories, $File::Find::name; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
}; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
_save_pwd { |
221
|
|
|
|
|
|
|
chdir $directory or die "Can't chdir to $directory: $!"; |
222
|
|
|
|
|
|
|
find($wanted, "."); |
223
|
|
|
|
|
|
|
foreach my $d (@directories) { |
224
|
|
|
|
|
|
|
mkpath(["$contentdir/$d"], $self->Verbose, 0770); |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
foreach my $f (@files) { |
227
|
|
|
|
|
|
|
copy($f, "$contentdir/$f") |
228
|
|
|
|
|
|
|
or die "Can't copy file $f to $contentdir: $!"; |
229
|
|
|
|
|
|
|
copy_stat($f, "$contentdir/$f"); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
}; |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
1; |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
=item export_all |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
Create an archive file (.tar.gz format) of both database and content. |
239
|
|
|
|
|
|
|
Two member variables control paths for the export: C specifies |
240
|
|
|
|
|
|
|
the temporary directory, where database and content files will be |
241
|
|
|
|
|
|
|
stored, and C specifies the path for the generated archive |
242
|
|
|
|
|
|
|
file. If not specified, then reasonable defaults are chosen (using the |
243
|
|
|
|
|
|
|
systems default temp directory). After the creation of the archive |
244
|
|
|
|
|
|
|
file, the temporary directory will be deleted completely. |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
=cut |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
sub export_all { |
249
|
|
|
|
|
|
|
my($self, %args) = @_; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
my @l = localtime; |
252
|
|
|
|
|
|
|
my $timestamp = sprintf "%04d%02d%02d-%02d%02d%02d", |
253
|
|
|
|
|
|
|
$l[5]+1900,$l[4],@l[3,2,1,0]; |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
if (defined $args{-destdir}) { |
256
|
|
|
|
|
|
|
$self->Tmpdir($args{-destdir}); |
257
|
|
|
|
|
|
|
mkpath $args{-destdir}; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
if (!defined $self->Tmpdir) { |
261
|
|
|
|
|
|
|
my $tmpdir = _tmpdir() . "/we_export.$timestamp"; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
if (-d $tmpdir) { |
264
|
|
|
|
|
|
|
rmtree([$tmpdir], $self->Verbose, 1); |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
mkdir $tmpdir, 0775 or die "Can't create $tmpdir: $!"; |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
$self->Tmpdir($tmpdir); |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
if (!-d $self->Tmpdir || !-w $self->Tmpdir) { |
272
|
|
|
|
|
|
|
die "The directory " . $self->Tmpdir . " does not exist or is not readable"; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
$self->export_db unless $args{-onlycontent}; |
276
|
|
|
|
|
|
|
$self->export_content unless $args{-onlydb}; |
277
|
|
|
|
|
|
|
$self->create_mtree unless $args{-onlycontent} || $args{-onlydb}; |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
return 1 if defined $args{-destdir}; |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
if (defined $args{-destfile}) { |
282
|
|
|
|
|
|
|
$self->Archive($args{-destfile}); |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
if (!defined $self->Archive) { |
286
|
|
|
|
|
|
|
$self->Archive(_tmpdir() . "/we_export.$timestamp.tar.gz"); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
_save_pwd { |
290
|
|
|
|
|
|
|
chdir $self->Tmpdir or die "Can't chdir to ".$self->Tmpdir.": $!"; |
291
|
|
|
|
|
|
|
if ($^O eq 'MSWin32' && eval q{ require Archive::Tar; 1 }) { |
292
|
|
|
|
|
|
|
my @files; |
293
|
|
|
|
|
|
|
find(sub { |
294
|
|
|
|
|
|
|
push @files, $File::Find::name if -f $_ && -r $_; |
295
|
|
|
|
|
|
|
}, "."); |
296
|
|
|
|
|
|
|
if (!@files) { |
297
|
|
|
|
|
|
|
warn "No files to archive"; |
298
|
|
|
|
|
|
|
} else { |
299
|
|
|
|
|
|
|
my $tar = Archive::Tar->new |
300
|
|
|
|
|
|
|
or die "Can't create Archive::Tar object"; |
301
|
|
|
|
|
|
|
$tar->add_files(@files); |
302
|
|
|
|
|
|
|
$tar->write($self->Archive, 9); |
303
|
|
|
|
|
|
|
if ($self->Verbose) { |
304
|
|
|
|
|
|
|
warn "Archived to @{[ $self->Archive ]}: @files\n"; |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
} else { |
308
|
|
|
|
|
|
|
my $v = $self->Verbose ? "v" : ""; |
309
|
|
|
|
|
|
|
#system("tar cf${v}z ".$self->Archive." *"); |
310
|
|
|
|
|
|
|
system("tar cf${v} - * | gzip > " . $self->Archive); |
311
|
|
|
|
|
|
|
if ($?/256 != 0) { |
312
|
|
|
|
|
|
|
warn "Error while creating ".$self->Archive.", please check.\n"; |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
}; |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
CLEANUP: |
318
|
|
|
|
|
|
|
rmtree([$self->Tmpdir], $self->Verbose, 1); |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
1; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
=item import_archive($tarfile, $destdir, %args) |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
For the specified tar archive C<$tarfile> (previously created by |
326
|
|
|
|
|
|
|
C), the content will be extracted to the directory |
327
|
|
|
|
|
|
|
C<$destdir>. The destination directory must not exist and will be |
328
|
|
|
|
|
|
|
created by the method. |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
Further arguments %args: |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
=over |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
=item -verbose => $boolean |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
Be verbose. |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
=item -force => $boolean |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
Extract even if destination directory exists. |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
=item -only => [DB1, ...] |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
Extract only specified databases. Note that content is B extracted. |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=item -chmod => $boolean |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
Make chmod manipulations (set everything to 0777 resp. 0666) if set to |
349
|
|
|
|
|
|
|
true. |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
=back |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
=cut |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
# Do not rename this to "import" :-) |
356
|
|
|
|
|
|
|
sub import_archive { |
357
|
|
|
|
|
|
|
my $self = shift; |
358
|
|
|
|
|
|
|
my($tarfile, $destdir, %args) = @_; |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
if (!ref $self) { |
361
|
|
|
|
|
|
|
$self = WE::Export->new(undef); |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
if ($args{-force}) { |
365
|
|
|
|
|
|
|
$self->Force($args{-force}); |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
if ($args{-verbose}) { |
368
|
|
|
|
|
|
|
$self->Verbose($args{-verbose}); |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
if ($args{"-chmod"}) { |
371
|
|
|
|
|
|
|
$self->_DirMode(0777); |
372
|
|
|
|
|
|
|
$self->_FileMode(0666); |
373
|
|
|
|
|
|
|
} else { |
374
|
|
|
|
|
|
|
$self->_DirMode(undef); |
375
|
|
|
|
|
|
|
$self->_FileMode(undef); |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
my $all = 1; |
379
|
|
|
|
|
|
|
my %only; |
380
|
|
|
|
|
|
|
if ($args{-only}) { |
381
|
|
|
|
|
|
|
%only = map { ($_ => 1) } @{ $args{-only} }; |
382
|
|
|
|
|
|
|
$all = 0; |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
if (-e $destdir && !$self->Force) { |
386
|
|
|
|
|
|
|
die "Destination directory $destdir must not exist"; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
mkpath($destdir, $self->Verbose, $self->_DirMode); |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
if (!file_name_is_absolute($tarfile)) { |
391
|
|
|
|
|
|
|
$tarfile = cwd()."/$tarfile"; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
_save_pwd { |
395
|
|
|
|
|
|
|
chdir $destdir or die "Can't change to $destdir: $!"; |
396
|
|
|
|
|
|
|
my @filelist; |
397
|
|
|
|
|
|
|
my @dirlist; |
398
|
|
|
|
|
|
|
if ($^O eq 'MSWin32' && eval q{ require Archive::Tar; 1 }) { |
399
|
|
|
|
|
|
|
my $tar = Archive::Tar->new($tarfile, 1) |
400
|
|
|
|
|
|
|
or die "Can't create tar object"; |
401
|
|
|
|
|
|
|
if ($self->Verbose) { |
402
|
|
|
|
|
|
|
warn "About to extract the following files from $tarfile:\n" . join(" ", $tar->list_files) . "\n"; |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
$tar->extract($tar->list_files); # extract() does not work! |
405
|
|
|
|
|
|
|
} else { |
406
|
|
|
|
|
|
|
my $v = $self->Verbose ? "v" : ""; |
407
|
|
|
|
|
|
|
#system("tar", "xf${v}pz", $tarfile); |
408
|
|
|
|
|
|
|
system("gzip -dc < $tarfile | tar xf${v}p -"); |
409
|
|
|
|
|
|
|
if ($?/256 != 0) { |
410
|
|
|
|
|
|
|
warn "Error while extracting from $tarfile, but continuing...\n"; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
@filelist = `gzip -dc < $tarfile | tar tf -`; |
413
|
|
|
|
|
|
|
chomp @filelist; |
414
|
|
|
|
|
|
|
for(my $f_i = $#filelist; $f_i >= 0; $f_i--) { |
415
|
|
|
|
|
|
|
my $f = $filelist[$f_i]; |
416
|
|
|
|
|
|
|
if (-d $f) { |
417
|
|
|
|
|
|
|
push @dirlist, $f; |
418
|
|
|
|
|
|
|
splice @filelist, $f_i, 1; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
my @db_files; |
424
|
|
|
|
|
|
|
for my $dbkey (qw(ObjDB UserDB OnlineUserDB NameDB)) { |
425
|
|
|
|
|
|
|
if ($all || $only{$dbkey}) { |
426
|
|
|
|
|
|
|
$self->exportdb_to_nativedb("$db_filename{$dbkey}.db.dd", ".", $dbkey); |
427
|
|
|
|
|
|
|
push @db_files, "$db_filename{$dbkey}.db"; |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
if (-e MTREE_FILE && is_in_path("mtree")) { |
431
|
|
|
|
|
|
|
my $xfile = $self->_create_mtree_x_file; |
432
|
|
|
|
|
|
|
system("mtree -X $xfile < " . MTREE_FILE); |
433
|
|
|
|
|
|
|
unlink $xfile; |
434
|
|
|
|
|
|
|
} elsif (@filelist) { |
435
|
|
|
|
|
|
|
if (defined $self->_FileMode) { |
436
|
|
|
|
|
|
|
warn "Changing mode of all files to " . |
437
|
|
|
|
|
|
|
sprintf("0%o", $self->_FileMode) . "...\n"; |
438
|
|
|
|
|
|
|
chmod $self->_FileMode, @filelist, @db_files; |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
if (defined $self->_DirMode) { |
441
|
|
|
|
|
|
|
warn "Changing mode of all directories to " . |
442
|
|
|
|
|
|
|
sprintf("0%o", $self->_DirMode) . "...\n"; |
443
|
|
|
|
|
|
|
chmod $self->_DirMode, @dirlist; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
} else { |
446
|
|
|
|
|
|
|
if (defined $self->_FileMode && defined $self->_DirMode) { |
447
|
|
|
|
|
|
|
warn "No mtree and no filelist/dirlist, no chmod manipulation possible"; |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
}; |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
1; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
# $type is either ObjDB or UserDB |
456
|
|
|
|
|
|
|
# This method will convert the Data::Dumper files to a DB_File. |
457
|
|
|
|
|
|
|
sub exportdb_to_nativedb { |
458
|
|
|
|
|
|
|
my($self, $dbfile, $destdir, $type) = @_; |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
if (!-d $destdir) { |
461
|
|
|
|
|
|
|
die "Destination directory $destdir does not exist"; |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
if (!defined $db_filename{$type} || $db_filename{$type} eq '') { |
464
|
|
|
|
|
|
|
die "Unsupported type $type"; |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
my $destfile = $destdir . "/" . $db_filename{$type} . ".db"; |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
if ($self->Force && -e $destfile) { |
469
|
|
|
|
|
|
|
unlink $destfile; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
tie my %db, 'DB_File', $destfile, O_RDWR|O_CREAT, 0644 |
472
|
|
|
|
|
|
|
or die "Can't tie to $destfile: $!"; |
473
|
|
|
|
|
|
|
if (scalar keys %db) { |
474
|
|
|
|
|
|
|
die "Database $destfile is not empty, please remove first"; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
my $s = Safe->new('WE::Export::Safe'); |
478
|
|
|
|
|
|
|
my $cwd = cwd; |
479
|
|
|
|
|
|
|
$s->rdo($dbfile) or die "Can't load $dbfile (in $cwd) with Safe::rdo: $!"; |
480
|
|
|
|
|
|
|
my $indb; |
481
|
|
|
|
|
|
|
{ |
482
|
|
|
|
|
|
|
no strict 'refs'; |
483
|
|
|
|
|
|
|
$indb = $ {"WE::Export::Safe::" . $type}; |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
if (!defined $indb || !UNIVERSAL::isa($indb, 'HASH')) { |
486
|
|
|
|
|
|
|
die "$type not defined in $dbfile"; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
while(my($k,$v) = each %$indb) { |
489
|
|
|
|
|
|
|
$db{$k} = $v; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
untie %db; |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
# XXX This assumes that all databases and content is in the same directory |
496
|
|
|
|
|
|
|
# as objdbd.db. Which may be wrong. |
497
|
|
|
|
|
|
|
sub create_mtree { |
498
|
|
|
|
|
|
|
my $self = shift; |
499
|
|
|
|
|
|
|
if (!is_in_path("mtree")) { |
500
|
|
|
|
|
|
|
warn "No mtree in PATH, skipping creation of .mtree file"; |
501
|
|
|
|
|
|
|
return; |
502
|
|
|
|
|
|
|
} |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
my $rootdb = $self->Root; |
505
|
|
|
|
|
|
|
my $objdb = $rootdb->ObjDB; |
506
|
|
|
|
|
|
|
my $objdbfile = $objdb->DBFile; |
507
|
|
|
|
|
|
|
my $dbdir = dirname($objdbfile); |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
my $xfile = $self->_create_mtree_x_file; |
510
|
|
|
|
|
|
|
my $mtree_output = `mtree -k flags,gid,mode,nlink,link,time,uid -X $xfile -c -p $dbdir`; |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
my $mtree_file = $self->Tmpdir . "/" . MTREE_FILE; |
513
|
|
|
|
|
|
|
open(MTREE_FH, ">$mtree_file") or die "Can't write $mtree_file: $!"; |
514
|
|
|
|
|
|
|
print MTREE_FH $mtree_output; |
515
|
|
|
|
|
|
|
close MTREE_FH; |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
unlink $xfile; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
sub _create_mtree_x_file { |
521
|
|
|
|
|
|
|
my $self = shift; |
522
|
|
|
|
|
|
|
my $xfile = _tmpdir() . "/.mtree.exclude.$$"; |
523
|
|
|
|
|
|
|
open(XFILE, ">$xfile") or die "Can't write to $xfile: $!"; |
524
|
|
|
|
|
|
|
print XFILE <
|
525
|
|
|
|
|
|
|
.svn |
526
|
|
|
|
|
|
|
CVS |
527
|
|
|
|
|
|
|
RCS |
528
|
|
|
|
|
|
|
*~ |
529
|
|
|
|
|
|
|
EOF |
530
|
|
|
|
|
|
|
close XFILE; |
531
|
|
|
|
|
|
|
$xfile; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# REPO BEGIN |
535
|
|
|
|
|
|
|
# REPO NAME tmpdir /home/e/eserte/src/repository |
536
|
|
|
|
|
|
|
# REPO MD5 c41d886135d054ba05e1b9eb0c157644 |
537
|
|
|
|
|
|
|
sub _tmpdir { |
538
|
|
|
|
|
|
|
foreach my $d ($ENV{TMPDIR}, $ENV{TEMP}, |
539
|
|
|
|
|
|
|
"/tmp", "/var/tmp", "/usr/tmp", "/temp") { |
540
|
|
|
|
|
|
|
next if !defined $d; |
541
|
|
|
|
|
|
|
next if !-d $d || !-w $d; |
542
|
|
|
|
|
|
|
return $d; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
undef; |
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
# REPO END |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
# REPO BEGIN |
549
|
|
|
|
|
|
|
# REPO NAME copy_stat /home/e/eserte/src/repository |
550
|
|
|
|
|
|
|
# REPO MD5 f567def1f7ce8f3361e474b026594660 |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
sub copy_stat { |
553
|
|
|
|
|
|
|
my($src, $dest) = @_; |
554
|
|
|
|
|
|
|
my @stat = ref $src eq 'ARRAY' ? @$src : stat($src); |
555
|
|
|
|
|
|
|
die "Can't stat $src: $!" if !@stat; |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
chmod $stat[2], $dest |
558
|
|
|
|
|
|
|
or warn "Can't chmod $dest to " . sprintf("0%o", $stat[2]) . ": $!"; |
559
|
|
|
|
|
|
|
chown $stat[4], $stat[5], $dest; |
560
|
|
|
|
|
|
|
# or do { |
561
|
|
|
|
|
|
|
# my $save_err = $!; # otherwise it's lost in the get... calls |
562
|
|
|
|
|
|
|
# warn "Can't chown $dest to " . |
563
|
|
|
|
|
|
|
# (getpwuid($stat[4]))[0] . "/" . |
564
|
|
|
|
|
|
|
# (getgrgid($stat[5]))[0] . ": $save_err"; |
565
|
|
|
|
|
|
|
# }; |
566
|
|
|
|
|
|
|
utime $stat[8], $stat[9], $dest |
567
|
|
|
|
|
|
|
or warn "Can't utime $dest to " . |
568
|
|
|
|
|
|
|
scalar(localtime $stat[8]) . "/" . |
569
|
|
|
|
|
|
|
scalar(localtime $stat[9]) . |
570
|
|
|
|
|
|
|
": $!"; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
# REPO END |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
1; |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
__END__ |