1 | #!/usr/bin/perl -w |
---|
2 | |
---|
3 | # Copyright (c) 2002,2003,2004,2005,2006,2007,2009 Dolby. All rights reserved. |
---|
4 | # |
---|
5 | # Licensed under the Academic Free License version 3.0. See LICENSE_AFL3.txt |
---|
6 | # or http://www.opensource.org/licenses/academic.php for a copy of the license |
---|
7 | # text. |
---|
8 | |
---|
9 | # $HeadURL: http://svn.apache.org/repos/asf/subversion/branches/1.6.x/contrib/client-side/svn_load_dirs/svn_load_dirs.pl.in $ |
---|
10 | # $LastChangedDate: 2009-10-12 12:57:16 +0000 (Mon, 12 Oct 2009) $ |
---|
11 | # $LastChangedBy: hwright $ |
---|
12 | # $LastChangedRevision: 880030 $ |
---|
13 | |
---|
14 | $| = 1; |
---|
15 | |
---|
16 | use strict; |
---|
17 | use Carp; |
---|
18 | use Cwd; |
---|
19 | use Digest::MD5 2.20; |
---|
20 | use File::Copy 2.03; |
---|
21 | use File::Find; |
---|
22 | use File::Path 1.0404; |
---|
23 | use File::Temp 0.12 qw(tempdir tempfile); |
---|
24 | use Getopt::Long 2.25; |
---|
25 | use Text::Wrap; |
---|
26 | use URI 1.17; |
---|
27 | use English; |
---|
28 | |
---|
29 | $Text::Wrap::columns = 72; |
---|
30 | |
---|
31 | # Specify the location of the svn command. |
---|
32 | my $svn = `which svn`; |
---|
33 | |
---|
34 | # Process the command line options. |
---|
35 | |
---|
36 | # The base URL for the portion of the repository to work in. Note |
---|
37 | # that this does not have to be the root of the subversion repository, |
---|
38 | # it can point to a subdirectory in the repository. |
---|
39 | my $repos_base_url; |
---|
40 | |
---|
41 | # The relative path from the repository base URL to work in to the |
---|
42 | # directory to load the input directories into. |
---|
43 | my $repos_load_rel_path; |
---|
44 | |
---|
45 | # To specify where tags, which are simply copies of the imported |
---|
46 | # directory, should be placed relative to the repository base URL, use |
---|
47 | # the -t command line option. This value must contain regular |
---|
48 | # expressions that match portions of the input directory names to |
---|
49 | # create an unique tag for each input directory. The regular |
---|
50 | # expressions are surrounded by a specified character to distinguish |
---|
51 | # the regular expression from the normal directory path. |
---|
52 | my $opt_import_tag_location; |
---|
53 | |
---|
54 | # Do not ask for any user input. Just go ahead and do everything. |
---|
55 | my $opt_no_user_input; |
---|
56 | |
---|
57 | # Do not automatically set the svn:executable property based on the |
---|
58 | # file's exe bit. |
---|
59 | my $opt_no_auto_exe; |
---|
60 | |
---|
61 | # Username to use for commits. |
---|
62 | my $opt_svn_username; |
---|
63 | |
---|
64 | # Password to use for commits. |
---|
65 | my $opt_svn_password; |
---|
66 | |
---|
67 | # Verbosity level. |
---|
68 | my $opt_verbose; |
---|
69 | |
---|
70 | # Path to already checked-out working copy. |
---|
71 | my $opt_existing_wc_dir; |
---|
72 | |
---|
73 | # List of filename patterns to ignore (as in .subversion/config's |
---|
74 | # "global-ignores" option). |
---|
75 | my $opt_glob_ignores; |
---|
76 | |
---|
77 | # This is the character used to separate regular expressions occuring |
---|
78 | # in the tag directory path from the path itself. |
---|
79 | my $REGEX_SEP_CHAR = '@'; |
---|
80 | |
---|
81 | # This specifies a configuration file that contains a list of regular |
---|
82 | # expressions to check against a file and the properties to set on |
---|
83 | # matching files. |
---|
84 | my $property_config_filename; |
---|
85 | |
---|
86 | GetOptions('no_user_input' => \$opt_no_user_input, |
---|
87 | 'no_auto_exe' => \$opt_no_auto_exe, |
---|
88 | 'property_cfg_filename=s' => \$property_config_filename, |
---|
89 | 'svn_password=s' => \$opt_svn_password, |
---|
90 | 'svn_username=s' => \$opt_svn_username, |
---|
91 | 'tag_location=s' => \$opt_import_tag_location, |
---|
92 | 'verbose+' => \$opt_verbose, |
---|
93 | 'wc=s' => \$opt_existing_wc_dir, |
---|
94 | 'glob_ignores=s' => \$opt_glob_ignores) |
---|
95 | or &usage; |
---|
96 | &usage("$0: too few arguments") if @ARGV < 2; |
---|
97 | |
---|
98 | $repos_base_url = shift; |
---|
99 | $repos_load_rel_path = shift; |
---|
100 | |
---|
101 | # Check that the repository base URL and the import directories do not |
---|
102 | # contain any ..'s. |
---|
103 | if ($repos_base_url =~ /\.{2}/) |
---|
104 | { |
---|
105 | die "$0: repos base URL $repos_base_url cannot contain ..'s.\n"; |
---|
106 | } |
---|
107 | if ($repos_load_rel_path =~ /\.{2}/) |
---|
108 | { |
---|
109 | die "$0: repos import relative directory path $repos_load_rel_path ", |
---|
110 | "cannot contain ..'s.\n"; |
---|
111 | } |
---|
112 | |
---|
113 | # If there are no directories listed on the command line, then the |
---|
114 | # directories are read from standard input. In this case, the |
---|
115 | # -no_user_input command line option must be specified. |
---|
116 | if (!@ARGV and !$opt_no_user_input) |
---|
117 | { |
---|
118 | &usage("$0: must use -no_user_input if no dirs listed on command line."); |
---|
119 | } |
---|
120 | |
---|
121 | # The tag option cannot be used when directories are read from |
---|
122 | # standard input because tags may collide and no user input can be |
---|
123 | # taken to verify that the input is ok. |
---|
124 | if (!@ARGV and $opt_import_tag_location) |
---|
125 | { |
---|
126 | &usage("$0: cannot use -tag_location when dirs are read from stdin."); |
---|
127 | } |
---|
128 | |
---|
129 | # If the tag directory is set, then the import directory cannot be '.'. |
---|
130 | if (defined $opt_import_tag_location and $repos_load_rel_path eq '.') |
---|
131 | { |
---|
132 | &usage("$0: cannot set import_dir to '.' and use -t command line option."); |
---|
133 | } |
---|
134 | |
---|
135 | # Set the svn command line options that are used anytime svn connects |
---|
136 | # to the repository. |
---|
137 | my @svn_use_repos_cmd_opts; |
---|
138 | &set_svn_use_repos_cmd_opts($opt_svn_username, $opt_svn_password); |
---|
139 | |
---|
140 | # Check that the tag directories do not contain any ..'s. Also, the |
---|
141 | # import and tag directories cannot be absolute. |
---|
142 | if (defined $opt_import_tag_location and $opt_import_tag_location =~ /\.{2}/) |
---|
143 | { |
---|
144 | die "$0: repos tag relative directory path $opt_import_tag_location ", |
---|
145 | "cannot contain ..'s.\n"; |
---|
146 | } |
---|
147 | if ($repos_load_rel_path =~ m|^/|) |
---|
148 | { |
---|
149 | die "$0: repos import relative directory path $repos_load_rel_path ", |
---|
150 | "cannot start with /.\n"; |
---|
151 | } |
---|
152 | if (defined $opt_import_tag_location and $opt_import_tag_location =~ m|^/|) |
---|
153 | { |
---|
154 | die "$0: repos tagrelative directory path $opt_import_tag_location ", |
---|
155 | "cannot start with /.\n"; |
---|
156 | } |
---|
157 | |
---|
158 | if (defined $opt_existing_wc_dir) |
---|
159 | { |
---|
160 | unless (-e $opt_existing_wc_dir) |
---|
161 | { |
---|
162 | die "$0: working copy '$opt_existing_wc_dir' does not exist.\n"; |
---|
163 | } |
---|
164 | |
---|
165 | unless (-d _) |
---|
166 | { |
---|
167 | die "$0: working copy '$opt_existing_wc_dir' is not a directory.\n"; |
---|
168 | } |
---|
169 | |
---|
170 | unless (-d "$opt_existing_wc_dir/.svn") |
---|
171 | { |
---|
172 | die "$0: working copy '$opt_existing_wc_dir' does not have .svn ", |
---|
173 | "directory.\n"; |
---|
174 | } |
---|
175 | |
---|
176 | $opt_existing_wc_dir = Cwd::abs_path($opt_existing_wc_dir) |
---|
177 | } |
---|
178 | |
---|
179 | # If no glob_ignores specified, try to deduce from config file, |
---|
180 | # or use the default below. |
---|
181 | my $ignores_str = |
---|
182 | '*.o *.lo *.la #*# .*.rej *.rej .*~ *~ .#* .DS_Store'; |
---|
183 | |
---|
184 | if ( defined $opt_glob_ignores) |
---|
185 | { |
---|
186 | $ignores_str = $opt_glob_ignores; |
---|
187 | } |
---|
188 | elsif ( -f "$ENV{HOME}/.subversion/config" ) |
---|
189 | { |
---|
190 | open my $conf, "$ENV{HOME}/.subversion/config"; |
---|
191 | while (<$conf>) |
---|
192 | { |
---|
193 | if ( /^global-ignores\s*=\s*(.*?)\s*$/ ) |
---|
194 | { |
---|
195 | $ignores_str = $1; |
---|
196 | last; |
---|
197 | } |
---|
198 | } |
---|
199 | } |
---|
200 | |
---|
201 | my @glob_ignores = map |
---|
202 | { |
---|
203 | s/\./\\\./g; s/\*/\.\*/g; "^$_\$"; |
---|
204 | } split(/\s+/, $ignores_str); |
---|
205 | unshift @glob_ignores, '\.svn$'; |
---|
206 | |
---|
207 | # Convert the string URL into a URI object. |
---|
208 | $repos_base_url =~ s|/*$||; |
---|
209 | my $repos_base_uri = URI->new($repos_base_url); |
---|
210 | |
---|
211 | # Check that $repos_load_rel_path is not a directory here implying |
---|
212 | # that a command line option was forgotten. |
---|
213 | if ($repos_load_rel_path ne '.' and -d $repos_load_rel_path) |
---|
214 | { |
---|
215 | die "$0: import_dir '$repos_load_rel_path' is a directory.\n"; |
---|
216 | } |
---|
217 | |
---|
218 | # The remaining command line arguments should be directories. Check |
---|
219 | # that they all exist and that there are no duplicates. |
---|
220 | if (@ARGV) |
---|
221 | { |
---|
222 | my %dirs; |
---|
223 | foreach my $dir (@ARGV) |
---|
224 | { |
---|
225 | unless (-e $dir) |
---|
226 | { |
---|
227 | die "$0: directory '$dir' does not exist.\n"; |
---|
228 | } |
---|
229 | |
---|
230 | unless (-d _) |
---|
231 | { |
---|
232 | die "$0: directory '$dir' is not a directory.\n"; |
---|
233 | } |
---|
234 | |
---|
235 | if ($dirs{$dir}) |
---|
236 | { |
---|
237 | die "$0: directory '$dir' is listed more than once on command ", |
---|
238 | "line.\n"; |
---|
239 | } |
---|
240 | $dirs{$dir} = 1; |
---|
241 | } |
---|
242 | } |
---|
243 | |
---|
244 | # Create the tag locations and print them for the user to review. |
---|
245 | # Check that there are no duplicate tags. |
---|
246 | my %load_tags; |
---|
247 | if (@ARGV and defined $opt_import_tag_location) |
---|
248 | { |
---|
249 | my %seen_tags; |
---|
250 | |
---|
251 | foreach my $load_dir (@ARGV) |
---|
252 | { |
---|
253 | my $load_tag = &get_tag_dir($load_dir); |
---|
254 | |
---|
255 | print "Directory $load_dir will be tagged as $load_tag\n"; |
---|
256 | |
---|
257 | if ($seen_tags{$load_tag}) |
---|
258 | { |
---|
259 | die "$0: duplicate tag generated.\n"; |
---|
260 | } |
---|
261 | $seen_tags{$load_tag} = 1; |
---|
262 | |
---|
263 | $load_tags{$load_dir} = $load_tag; |
---|
264 | } |
---|
265 | |
---|
266 | exit 0 unless &get_answer("Please examine identified tags. Are they " . |
---|
267 | "acceptable? (Y/n) ", 'ny', 1); |
---|
268 | print "\n"; |
---|
269 | } |
---|
270 | |
---|
271 | # Load the property configuration filename, if one was specified, into |
---|
272 | # an array of hashes, where each hash contains a regular expression |
---|
273 | # and a property to apply to the file if the regular expression |
---|
274 | # matches. |
---|
275 | my @property_settings; |
---|
276 | if (defined $property_config_filename and length $property_config_filename) |
---|
277 | { |
---|
278 | open(CFG, $property_config_filename) |
---|
279 | or die "$0: cannot open '$property_config_filename' for reading: $!\n"; |
---|
280 | |
---|
281 | my $ok = 1; |
---|
282 | |
---|
283 | while (my $line = <CFG>) |
---|
284 | { |
---|
285 | next if $line =~ /^\s*$/; |
---|
286 | next if $line =~ /^\s*#/; |
---|
287 | |
---|
288 | # Split the input line into words taking into account that |
---|
289 | # single or double quotes may define a single word with |
---|
290 | # whitespace in it. The format for the file is |
---|
291 | # regex control property_name property_value |
---|
292 | my @line = &split_line($line); |
---|
293 | next if @line == 0; |
---|
294 | |
---|
295 | unless (@line == 2 or @line == 4) |
---|
296 | { |
---|
297 | warn "$0: line $. of '$property_config_filename' has to have 2 ", |
---|
298 | "or 4 columns.\n"; |
---|
299 | $ok = 0; |
---|
300 | next; |
---|
301 | } |
---|
302 | my ($regex, $control, $property_name, $property_value) = @line; |
---|
303 | |
---|
304 | unless ($control eq 'break' or $control eq 'cont') |
---|
305 | { |
---|
306 | warn "$0: line $. of '$property_config_filename' has illegal ", |
---|
307 | "value for column 3 '$control', must be 'break' or 'cont'.\n"; |
---|
308 | $ok = 0; |
---|
309 | next; |
---|
310 | } |
---|
311 | |
---|
312 | # Compile the regular expression. |
---|
313 | my $re; |
---|
314 | eval { $re = qr/$regex/i }; |
---|
315 | if ($@) |
---|
316 | { |
---|
317 | warn "$0: line $. of '$property_config_filename' regex '$regex' ", |
---|
318 | "does not compile:\n$@\n"; |
---|
319 | $ok = 0; |
---|
320 | next; |
---|
321 | } |
---|
322 | |
---|
323 | push(@property_settings, {name => $property_name, |
---|
324 | value => $property_value, |
---|
325 | control => $control, |
---|
326 | re => $re}); |
---|
327 | } |
---|
328 | close(CFG) |
---|
329 | or warn "$0: error in closing '$property_config_filename' for ", |
---|
330 | "reading: $!\n"; |
---|
331 | |
---|
332 | exit 1 unless $ok; |
---|
333 | } |
---|
334 | |
---|
335 | # Check that the svn base URL works by running svn log on it. Only |
---|
336 | # get the HEAD revision log message; there's no need to waste |
---|
337 | # bandwidth seeing all of the log messages. |
---|
338 | print "Checking that the base URL is a Subversion repository.\n"; |
---|
339 | read_from_process($svn, 'log', '-r', 'HEAD', |
---|
340 | @svn_use_repos_cmd_opts, $repos_base_uri); |
---|
341 | print "\n"; |
---|
342 | |
---|
343 | my $orig_cwd = cwd; |
---|
344 | |
---|
345 | # The first step is to determine the root of the svn repository. Do |
---|
346 | # this with the svn log command. Take the svn_url hostname and port |
---|
347 | # as the initial url and append to it successive portions of the final |
---|
348 | # path until svn log succeeds. |
---|
349 | print "Finding the root URL of the Subversion repository.\n"; |
---|
350 | my $repos_root_uri; |
---|
351 | my $repos_root_uri_path; |
---|
352 | my $repos_base_path_segment; |
---|
353 | { |
---|
354 | my $r = $repos_base_uri->clone; |
---|
355 | my @path_segments = grep { length($_) } $r->path_segments; |
---|
356 | my @repos_base_path_segments = @path_segments; |
---|
357 | unshift(@path_segments, ''); |
---|
358 | $r->path(''); |
---|
359 | my @r_path_segments; |
---|
360 | |
---|
361 | while (@path_segments) |
---|
362 | { |
---|
363 | $repos_root_uri_path = shift @path_segments; |
---|
364 | push(@r_path_segments, $repos_root_uri_path); |
---|
365 | $r->path_segments(@r_path_segments); |
---|
366 | if (safe_read_from_pipe($svn, 'log', '-r', 'HEAD', |
---|
367 | @svn_use_repos_cmd_opts, $r) == 0) |
---|
368 | { |
---|
369 | $repos_root_uri = $r; |
---|
370 | last; |
---|
371 | } |
---|
372 | shift @repos_base_path_segments; |
---|
373 | } |
---|
374 | $repos_base_path_segment = join('/', @repos_base_path_segments); |
---|
375 | } |
---|
376 | |
---|
377 | if ($repos_root_uri) |
---|
378 | { |
---|
379 | print "Determined that the svn root URL is $repos_root_uri.\n\n"; |
---|
380 | } |
---|
381 | else |
---|
382 | { |
---|
383 | die "$0: cannot determine root svn URL.\n"; |
---|
384 | } |
---|
385 | |
---|
386 | # Create a temporary directory for svn to work in. |
---|
387 | my $temp_dir = tempdir( "svn_load_dirs_XXXXXXXXXX", TMPDIR => 1 ); |
---|
388 | |
---|
389 | # Put in a signal handler to clean up any temporary directories. |
---|
390 | sub catch_signal { |
---|
391 | my $signal = shift; |
---|
392 | warn "$0: caught signal $signal. Quitting now.\n"; |
---|
393 | exit 1; |
---|
394 | } |
---|
395 | |
---|
396 | $SIG{HUP} = \&catch_signal; |
---|
397 | $SIG{INT} = \&catch_signal; |
---|
398 | $SIG{TERM} = \&catch_signal; |
---|
399 | $SIG{PIPE} = \&catch_signal; |
---|
400 | |
---|
401 | # Create an object that when DESTROY'ed will delete the temporary |
---|
402 | # directory. The CLEANUP flag to tempdir should do this, but they |
---|
403 | # call rmtree with 1 as the last argument which takes extra security |
---|
404 | # measures that do not clean up the .svn directories. |
---|
405 | my $temp_dir_cleanup = Temp::Delete->new; |
---|
406 | |
---|
407 | # Determine the native end of line style for this system. Do this the |
---|
408 | # most portable way, by writing a file with a single \n in non-binary |
---|
409 | # mode and then reading the file in binary mode. |
---|
410 | my $native_eol = &determine_native_eol; |
---|
411 | |
---|
412 | # Check if all the directories exist to load the directories into the |
---|
413 | # repository. If not, ask if they should be created. For tags, do |
---|
414 | # not create the tag directory itself, that is done on the svn cp. |
---|
415 | { |
---|
416 | print "Finding if any directories need to be created in repository.\n"; |
---|
417 | |
---|
418 | my @dirs_to_create; |
---|
419 | my @urls_to_create; |
---|
420 | my %seen_dir; |
---|
421 | my @load_tags_without_last_segment; |
---|
422 | |
---|
423 | # Assume that the last portion of the tag directory contains the |
---|
424 | # version number and remove it from the directories to create, |
---|
425 | # because the tag directory will be created by svn cp. |
---|
426 | foreach my $load_tag (sort values %load_tags) |
---|
427 | { |
---|
428 | # Skip this tag if there is only one segment in its name. |
---|
429 | my $index = rindex($load_tag, '/'); |
---|
430 | next if $index == -1; |
---|
431 | |
---|
432 | # Trim off the last segment and record the result. |
---|
433 | push(@load_tags_without_last_segment, substr($load_tag, 0, $index)); |
---|
434 | } |
---|
435 | |
---|
436 | foreach my $dir ($repos_load_rel_path, @load_tags_without_last_segment) |
---|
437 | { |
---|
438 | next unless length $dir; |
---|
439 | my $d = ''; |
---|
440 | foreach my $segment (split('/', $dir)) |
---|
441 | { |
---|
442 | $d = length $d ? "$d/$segment" : $segment; |
---|
443 | my $url = "$repos_base_url/$d"; |
---|
444 | unless ($seen_dir{$d}) |
---|
445 | { |
---|
446 | $seen_dir{$d} = 1; |
---|
447 | if (safe_read_from_pipe($svn, 'log', '-r', 'HEAD', |
---|
448 | @svn_use_repos_cmd_opts, $url) != 0) |
---|
449 | { |
---|
450 | push(@dirs_to_create, $d); |
---|
451 | push(@urls_to_create, $url); |
---|
452 | } |
---|
453 | } |
---|
454 | } |
---|
455 | } |
---|
456 | |
---|
457 | if (@dirs_to_create) |
---|
458 | { |
---|
459 | print "The following directories do not exist and need to exist:\n"; |
---|
460 | foreach my $dir (@dirs_to_create) |
---|
461 | { |
---|
462 | print " $dir\n"; |
---|
463 | } |
---|
464 | exit 0 unless &get_answer("You must add them now to load the " . |
---|
465 | "directories. Continue (Y/n)? ", 'ny', 1); |
---|
466 | |
---|
467 | my $message = "Create directories to load project into.\n\n"; |
---|
468 | |
---|
469 | foreach my $dir (@dirs_to_create) |
---|
470 | { |
---|
471 | if (length $repos_base_path_segment) |
---|
472 | { |
---|
473 | $message .= "* $repos_base_path_segment/$dir: New directory.\n"; |
---|
474 | } |
---|
475 | else |
---|
476 | { |
---|
477 | $message .= "* $dir: New directory.\n"; |
---|
478 | } |
---|
479 | } |
---|
480 | $message = wrap('', ' ', $message); |
---|
481 | |
---|
482 | read_from_process($svn, 'mkdir', @svn_use_repos_cmd_opts, |
---|
483 | '-m', $message, @urls_to_create); |
---|
484 | } |
---|
485 | else |
---|
486 | { |
---|
487 | print "No directories need to be created to prepare repository.\n"; |
---|
488 | } |
---|
489 | } |
---|
490 | |
---|
491 | # Either checkout a new working copy from the repository or use an |
---|
492 | # existing working copy. |
---|
493 | if (defined $opt_existing_wc_dir) |
---|
494 | { |
---|
495 | # Update an already existing working copy. |
---|
496 | print "Not checking out anything; using existing working directory at\n"; |
---|
497 | print "$opt_existing_wc_dir\n"; |
---|
498 | |
---|
499 | chdir($opt_existing_wc_dir) |
---|
500 | or die "$0: cannot chdir '$opt_existing_wc_dir': $!\n"; |
---|
501 | |
---|
502 | read_from_process($svn, 'update', @svn_use_repos_cmd_opts); |
---|
503 | } |
---|
504 | else |
---|
505 | { |
---|
506 | # Check out the svn repository starting at the svn URL into a |
---|
507 | # fixed directory name. |
---|
508 | my $checkout_dir_name = 'my_import_wc'; |
---|
509 | |
---|
510 | # Check out only the directory being imported to, otherwise the |
---|
511 | # checkout of the entire base URL can be very huge, if it contains |
---|
512 | # a large number of tags. |
---|
513 | my $checkout_url; |
---|
514 | if ($repos_load_rel_path eq '.') |
---|
515 | { |
---|
516 | $checkout_url = $repos_base_url; |
---|
517 | } |
---|
518 | else |
---|
519 | { |
---|
520 | $checkout_url = "$repos_base_url/$repos_load_rel_path"; |
---|
521 | } |
---|
522 | |
---|
523 | print "Checking out $checkout_url into $temp_dir/$checkout_dir_name\n"; |
---|
524 | |
---|
525 | chdir($temp_dir) |
---|
526 | or die "$0: cannot chdir '$temp_dir': $!\n"; |
---|
527 | |
---|
528 | read_from_process($svn, 'checkout', |
---|
529 | @svn_use_repos_cmd_opts, |
---|
530 | $checkout_url, $checkout_dir_name); |
---|
531 | |
---|
532 | chdir($checkout_dir_name) |
---|
533 | or die "$0: cannot chdir '$checkout_dir_name': $!\n"; |
---|
534 | } |
---|
535 | |
---|
536 | # At this point, the current working directory is the top level |
---|
537 | # directory of the working copy. Record the absolute path to this |
---|
538 | # location because the script will chdir back here later on. |
---|
539 | my $wc_import_dir_cwd = cwd; |
---|
540 | |
---|
541 | # Set up the names for the path to the import and tag directories. |
---|
542 | my $repos_load_abs_path; |
---|
543 | if ($repos_load_rel_path eq '.') |
---|
544 | { |
---|
545 | $repos_load_abs_path = length($repos_base_path_segment) ? |
---|
546 | $repos_base_path_segment : "/"; |
---|
547 | } |
---|
548 | else |
---|
549 | { |
---|
550 | $repos_load_abs_path = length($repos_base_path_segment) ? |
---|
551 | "$repos_base_path_segment/$repos_load_rel_path" : |
---|
552 | $repos_load_rel_path; |
---|
553 | } |
---|
554 | |
---|
555 | # Now go through each source directory and copy each file from the |
---|
556 | # source directory to the target directory. For new target files, add |
---|
557 | # them to svn. For files that no longer exist, delete them. |
---|
558 | my $print_rename_message = 1; |
---|
559 | my @load_dirs = @ARGV; |
---|
560 | while (defined (my $load_dir = &get_next_load_dir)) |
---|
561 | { |
---|
562 | my $load_tag = $load_tags{$load_dir}; |
---|
563 | |
---|
564 | if (defined $load_tag) |
---|
565 | { |
---|
566 | print "\nLoading $load_dir and will save in tag $load_tag.\n"; |
---|
567 | } |
---|
568 | else |
---|
569 | { |
---|
570 | print "\nLoading $load_dir.\n"; |
---|
571 | } |
---|
572 | |
---|
573 | # The first hash is keyed by the old name in a rename and the |
---|
574 | # second by the new name. The last variable contains a list of |
---|
575 | # old and new filenames in a rename. |
---|
576 | my %rename_from_files; |
---|
577 | my %rename_to_files; |
---|
578 | my @renamed_filenames; |
---|
579 | |
---|
580 | unless ($opt_no_user_input) |
---|
581 | { |
---|
582 | my $repeat_loop; |
---|
583 | do |
---|
584 | { |
---|
585 | $repeat_loop = 0; |
---|
586 | |
---|
587 | my %add_files; |
---|
588 | my %del_files; |
---|
589 | |
---|
590 | # Get the list of files and directories in the repository |
---|
591 | # working copy. This hash is called %del_files because |
---|
592 | # each file or directory will be deleted from the hash |
---|
593 | # using the list of files and directories in the source |
---|
594 | # directory, leaving the files and directories that need |
---|
595 | # to be deleted. |
---|
596 | %del_files = &recursive_ls_and_hash($wc_import_dir_cwd); |
---|
597 | |
---|
598 | # This anonymous subroutine finds all the files and |
---|
599 | # directories in the directory to load. It notes the file |
---|
600 | # type and for each file found, it deletes it from |
---|
601 | # %del_files. |
---|
602 | my $wanted = sub |
---|
603 | { |
---|
604 | s#^\./##; |
---|
605 | return if $_ eq '.'; |
---|
606 | |
---|
607 | my $source_path = $_; |
---|
608 | my $dest_path = "$wc_import_dir_cwd/$_"; |
---|
609 | |
---|
610 | my ($source_type) = &file_info($source_path); |
---|
611 | my ($dest_type) = &file_info($dest_path); |
---|
612 | |
---|
613 | # Fail if the destination type exists but is of a |
---|
614 | # different type of file than the source type. |
---|
615 | if ($dest_type ne '0' and $source_type ne $dest_type) |
---|
616 | { |
---|
617 | die "$0: does not handle changing source and destination ", |
---|
618 | "type for '$source_path'.\n"; |
---|
619 | } |
---|
620 | |
---|
621 | if ($source_type ne 'd' and |
---|
622 | $source_type ne 'f' and |
---|
623 | $source_type ne 'l') |
---|
624 | { |
---|
625 | warn "$0: skipping loading file '$source_path' of type ", |
---|
626 | "'$source_type'.\n"; |
---|
627 | unless ($opt_no_user_input) |
---|
628 | { |
---|
629 | print STDERR "Press return to continue: "; |
---|
630 | <STDIN>; |
---|
631 | } |
---|
632 | return; |
---|
633 | } |
---|
634 | |
---|
635 | unless (defined delete $del_files{$source_path}) |
---|
636 | { |
---|
637 | $add_files{$source_path}{type} = $source_type; |
---|
638 | } |
---|
639 | }; |
---|
640 | |
---|
641 | # Now change into the directory containing the files to |
---|
642 | # load. First change to the original directory where this |
---|
643 | # script was run so that if the specified directory is a |
---|
644 | # relative directory path, then the script can change into |
---|
645 | # it. |
---|
646 | chdir($orig_cwd) |
---|
647 | or die "$0: cannot chdir '$orig_cwd': $!\n"; |
---|
648 | chdir($load_dir) |
---|
649 | or die "$0: cannot chdir '$load_dir': $!\n"; |
---|
650 | |
---|
651 | find({no_chdir => 1, |
---|
652 | preprocess => sub { sort { $b cmp $a } |
---|
653 | grep { $_ !~ /^[._]svn$/ } @_ }, |
---|
654 | wanted => $wanted |
---|
655 | }, '.'); |
---|
656 | |
---|
657 | # At this point %add_files contains the list of new files |
---|
658 | # and directories to be created in the working copy tree |
---|
659 | # and %del_files contains the files and directories that |
---|
660 | # need to be deleted. Because there may be renames that |
---|
661 | # have taken place, give the user the opportunity to |
---|
662 | # rename any deleted files and directories to ones being |
---|
663 | # added. |
---|
664 | my @add_files = sort keys %add_files; |
---|
665 | my @del_files = sort keys %del_files; |
---|
666 | |
---|
667 | # Because the source code management system may keep the |
---|
668 | # original renamed file or directory in the working copy |
---|
669 | # until a commit, remove them from the list of deleted |
---|
670 | # files or directories. |
---|
671 | &filter_renamed_files(\@del_files, \%rename_from_files); |
---|
672 | |
---|
673 | # Now change into the working copy directory in case any |
---|
674 | # renames need to be performed. |
---|
675 | chdir($wc_import_dir_cwd) |
---|
676 | or die "$0: cannot chdir '$wc_import_dir_cwd': $!\n"; |
---|
677 | |
---|
678 | # Only do renames if there are both added and deleted |
---|
679 | # files and directories. |
---|
680 | if (@add_files and @del_files) |
---|
681 | { |
---|
682 | my $max = @add_files > @del_files ? @add_files : @del_files; |
---|
683 | |
---|
684 | # Print the files that have been added and deleted. |
---|
685 | # Find the deleted file with the longest name and use |
---|
686 | # that for the width of the filename column. Add one |
---|
687 | # to the filename width to let the directory / |
---|
688 | # character be appended to a directory name. |
---|
689 | my $line_number_width = 4; |
---|
690 | my $filename_width = 0; |
---|
691 | foreach my $f (@del_files) |
---|
692 | { |
---|
693 | my $l = length($f); |
---|
694 | $filename_width = $l if $l > $filename_width; |
---|
695 | } |
---|
696 | ++$filename_width; |
---|
697 | my $printf_format = "%${line_number_width}d"; |
---|
698 | |
---|
699 | if ($print_rename_message) |
---|
700 | { |
---|
701 | $print_rename_message = 0; |
---|
702 | print "\n", |
---|
703 | "The following table lists files and directories that\n", |
---|
704 | "exist in either the Subversion repository or the\n", |
---|
705 | "directory to be imported but not both. You now have\n", |
---|
706 | "the opportunity to match them up as renames instead\n", |
---|
707 | "of deletes and adds. This is a Good Thing as it'll\n", |
---|
708 | "make the repository take less space.\n\n", |
---|
709 | "The left column lists files and directories that\n", |
---|
710 | "exist in the Subversion repository and do not exist\n", |
---|
711 | "in the directory being imported. The right column\n", |
---|
712 | "lists files and directories that exist in the\n", |
---|
713 | "directory being imported. Match up a deleted item\n", |
---|
714 | "from the left column with an added item from the\n", |
---|
715 | "right column. Note the line numbers on the left\n", |
---|
716 | "which you type into this script to have a rename\n", |
---|
717 | "performed.\n"; |
---|
718 | } |
---|
719 | |
---|
720 | # Sort the added and deleted files and directories by |
---|
721 | # the lowercase versions of their basenames instead of |
---|
722 | # their complete path, which makes finding files that |
---|
723 | # were moved into different directories easier to |
---|
724 | # match up. |
---|
725 | @add_files = map { $_->[0] } |
---|
726 | sort { $a->[1] cmp $b->[1] } |
---|
727 | map { [$_->[0], lc($_->[1])] } |
---|
728 | map { [$_, m#([^/]+)$#] } |
---|
729 | @add_files; |
---|
730 | @del_files = map { $_->[0] } |
---|
731 | sort { $a->[1] cmp $b->[1] } |
---|
732 | map { [$_->[0], lc($_->[1])] } |
---|
733 | map { [$_, m#([^/]+)$#] } |
---|
734 | @del_files; |
---|
735 | |
---|
736 | RELIST: |
---|
737 | |
---|
738 | for (my $i=0; $i<$max; ++$i) |
---|
739 | { |
---|
740 | my $add_filename = ''; |
---|
741 | my $del_filename = ''; |
---|
742 | if ($i < @add_files) |
---|
743 | { |
---|
744 | $add_filename = $add_files[$i]; |
---|
745 | if ($add_files{$add_filename}{type} eq 'd') |
---|
746 | { |
---|
747 | $add_filename .= '/'; |
---|
748 | } |
---|
749 | } |
---|
750 | if ($i < @del_files) |
---|
751 | { |
---|
752 | $del_filename = $del_files[$i]; |
---|
753 | if ($del_files{$del_filename}{type} eq 'd') |
---|
754 | { |
---|
755 | $del_filename .= '/'; |
---|
756 | } |
---|
757 | } |
---|
758 | |
---|
759 | if ($i % 22 == 0) |
---|
760 | { |
---|
761 | print |
---|
762 | "\n", |
---|
763 | " " x $line_number_width, |
---|
764 | " ", |
---|
765 | "Deleted", " " x ($filename_width-length("Deleted")), |
---|
766 | " ", |
---|
767 | "Added\n"; |
---|
768 | } |
---|
769 | |
---|
770 | printf $printf_format, $i; |
---|
771 | print " ", $del_filename, |
---|
772 | "_" x ($filename_width - length($del_filename)), |
---|
773 | " ", $add_filename, "\n"; |
---|
774 | |
---|
775 | if (($i+1) % 22 == 0) |
---|
776 | { |
---|
777 | unless (&get_answer("Continue printing (Y/n)? ", |
---|
778 | 'ny', 1)) |
---|
779 | { |
---|
780 | last; |
---|
781 | } |
---|
782 | } |
---|
783 | } |
---|
784 | |
---|
785 | # Get the feedback from the user. |
---|
786 | my $line; |
---|
787 | my $add_filename; |
---|
788 | my $add_index; |
---|
789 | my $del_filename; |
---|
790 | my $del_index; |
---|
791 | my $got_line = 0; |
---|
792 | do { |
---|
793 | print "Enter two indexes for each column to rename, ", |
---|
794 | "(R)elist, or (F)inish: "; |
---|
795 | $line = <STDIN>; |
---|
796 | $line = '' unless defined $line; |
---|
797 | if ($line =~ /^R$/i ) |
---|
798 | { |
---|
799 | goto RELIST; |
---|
800 | } |
---|
801 | |
---|
802 | if ($line =~ /^F$/i) |
---|
803 | { |
---|
804 | $got_line = 1; |
---|
805 | } |
---|
806 | elsif ($line =~ /^(\d+)\s+(\d+)$/) |
---|
807 | { |
---|
808 | print "\n"; |
---|
809 | |
---|
810 | $del_index = $1; |
---|
811 | $add_index = $2; |
---|
812 | if ($del_index >= @del_files) |
---|
813 | { |
---|
814 | print "Delete index $del_index is larger than ", |
---|
815 | "maximum index of ", scalar @del_files - 1, |
---|
816 | ".\n"; |
---|
817 | $del_index = undef; |
---|
818 | } |
---|
819 | if ($add_index > @add_files) |
---|
820 | { |
---|
821 | print "Add index $add_index is larger than maximum ", |
---|
822 | "index of ", scalar @add_files - 1, ".\n"; |
---|
823 | $add_index = undef; |
---|
824 | } |
---|
825 | $got_line = defined $del_index && defined $add_index; |
---|
826 | |
---|
827 | # Check that the file or directory to be renamed |
---|
828 | # has the same file type. |
---|
829 | if ($got_line) |
---|
830 | { |
---|
831 | $add_filename = $add_files[$add_index]; |
---|
832 | $del_filename = $del_files[$del_index]; |
---|
833 | if ($add_files{$add_filename}{type} ne |
---|
834 | $del_files{$del_filename}{type}) |
---|
835 | { |
---|
836 | print "File types for $del_filename and ", |
---|
837 | "$add_filename differ.\n"; |
---|
838 | $got_line = undef; |
---|
839 | } |
---|
840 | } |
---|
841 | } |
---|
842 | } until ($got_line); |
---|
843 | |
---|
844 | if ($line !~ /^F$/i) |
---|
845 | { |
---|
846 | print "Renaming $del_filename to $add_filename.\n"; |
---|
847 | |
---|
848 | $repeat_loop = 1; |
---|
849 | |
---|
850 | # Because subversion cannot rename the same file |
---|
851 | # or directory twice, which includes doing a |
---|
852 | # rename of a file in a directory that was |
---|
853 | # previously renamed, a commit has to be |
---|
854 | # performed. Check if the file or directory being |
---|
855 | # renamed now would cause such a problem and |
---|
856 | # commit if so. |
---|
857 | my $do_commit_now = 0; |
---|
858 | foreach my $rename_to_filename (keys %rename_to_files) |
---|
859 | { |
---|
860 | if (contained_in($del_filename, |
---|
861 | $rename_to_filename, |
---|
862 | $rename_to_files{$rename_to_filename}{type})) |
---|
863 | { |
---|
864 | $do_commit_now = 1; |
---|
865 | last; |
---|
866 | } |
---|
867 | } |
---|
868 | |
---|
869 | if ($do_commit_now) |
---|
870 | { |
---|
871 | print "Now committing previously run renames.\n"; |
---|
872 | &commit_renames($load_dir, |
---|
873 | \@renamed_filenames, |
---|
874 | \%rename_from_files, |
---|
875 | \%rename_to_files); |
---|
876 | } |
---|
877 | |
---|
878 | push(@renamed_filenames, $del_filename, $add_filename); |
---|
879 | { |
---|
880 | my $d = $del_files{$del_filename}; |
---|
881 | $rename_from_files{$del_filename} = $d; |
---|
882 | $rename_to_files{$add_filename} = $d; |
---|
883 | } |
---|
884 | |
---|
885 | # Check that any required directories to do the |
---|
886 | # rename exist. |
---|
887 | my @add_segments = split('/', $add_filename); |
---|
888 | pop(@add_segments); |
---|
889 | my $add_dir = ''; |
---|
890 | my @add_dirs; |
---|
891 | foreach my $segment (@add_segments) |
---|
892 | { |
---|
893 | $add_dir = length($add_dir) ? "$add_dir/$segment" : |
---|
894 | $segment; |
---|
895 | unless (-d $add_dir) |
---|
896 | { |
---|
897 | push(@add_dirs, $add_dir); |
---|
898 | } |
---|
899 | } |
---|
900 | |
---|
901 | if (@add_dirs) |
---|
902 | { |
---|
903 | read_from_process($svn, 'mkdir', @add_dirs); |
---|
904 | } |
---|
905 | |
---|
906 | read_from_process($svn, 'mv', |
---|
907 | $del_filename, $add_filename); |
---|
908 | } |
---|
909 | } |
---|
910 | } while ($repeat_loop); |
---|
911 | } |
---|
912 | |
---|
913 | # If there are any renames that have not been committed, then do |
---|
914 | # that now. |
---|
915 | if (@renamed_filenames) |
---|
916 | { |
---|
917 | &commit_renames($load_dir, |
---|
918 | \@renamed_filenames, |
---|
919 | \%rename_from_files, |
---|
920 | \%rename_to_files); |
---|
921 | } |
---|
922 | |
---|
923 | # At this point all renames have been performed. Now get the |
---|
924 | # final list of files and directories in the working copy |
---|
925 | # directory. The %add_files hash will contain the list of files |
---|
926 | # and directories to add to the working copy and %del_files starts |
---|
927 | # with all the files already in the working copy and gets files |
---|
928 | # removed that are in the imported directory, which results in a |
---|
929 | # list of files that should be deleted. %upd_files holds the list |
---|
930 | # of files that have been updated. |
---|
931 | my %add_files; |
---|
932 | my %del_files = &recursive_ls_and_hash($wc_import_dir_cwd); |
---|
933 | my %upd_files; |
---|
934 | |
---|
935 | # This anonymous subroutine copies files from the source directory |
---|
936 | # to the working copy directory. |
---|
937 | my $wanted = sub |
---|
938 | { |
---|
939 | s#^\./##; |
---|
940 | return if $_ eq '.'; |
---|
941 | |
---|
942 | my $source_path = $_; |
---|
943 | my $dest_path = "$wc_import_dir_cwd/$_"; |
---|
944 | |
---|
945 | my ($source_type, $source_is_exe) = &file_info($source_path); |
---|
946 | my ($dest_type) = &file_info($dest_path); |
---|
947 | |
---|
948 | return if ($source_type ne 'd' and |
---|
949 | $source_type ne 'f' and |
---|
950 | $source_type ne 'l'); |
---|
951 | |
---|
952 | # Fail if the destination type exists but is of a different |
---|
953 | # type of file than the source type. |
---|
954 | if ($dest_type ne '0' and $source_type ne $dest_type) |
---|
955 | { |
---|
956 | die "$0: does not handle changing source and destination type ", |
---|
957 | "for '$source_path'.\n"; |
---|
958 | } |
---|
959 | |
---|
960 | # Determine if the file is being added or is an update to an |
---|
961 | # already existing file using the file's digest. |
---|
962 | my $del_info = delete $del_files{$source_path}; |
---|
963 | if (defined $del_info) |
---|
964 | { |
---|
965 | if (defined (my $del_digest = $del_info->{digest})) |
---|
966 | { |
---|
967 | my $new_digest = &digest_hash_file($source_path); |
---|
968 | if ($new_digest ne $del_digest) |
---|
969 | { |
---|
970 | print "U $source_path\n"; |
---|
971 | $upd_files{$source_path} = $del_info; |
---|
972 | } |
---|
973 | } |
---|
974 | } |
---|
975 | else |
---|
976 | { |
---|
977 | print "A $source_path\n"; |
---|
978 | $add_files{$source_path}{type} = $source_type; |
---|
979 | |
---|
980 | # Create an array reference to hold the list of properties |
---|
981 | # to apply to this object. |
---|
982 | unless (defined $add_files{$source_path}{properties}) |
---|
983 | { |
---|
984 | $add_files{$source_path}{properties} = []; |
---|
985 | } |
---|
986 | |
---|
987 | # Go through the list of properties for a match on this |
---|
988 | # file or directory and if there is a match, then apply |
---|
989 | # the property to it. |
---|
990 | foreach my $property (@property_settings) |
---|
991 | { |
---|
992 | my $re = $property->{re}; |
---|
993 | if ($source_path =~ $re) |
---|
994 | { |
---|
995 | my $property_name = $property->{name}; |
---|
996 | my $property_value = $property->{value}; |
---|
997 | |
---|
998 | # The property value may not be set in the |
---|
999 | # configuration file, since the user may just want |
---|
1000 | # to set the control flag. |
---|
1001 | if (defined $property_name and defined $property_value) |
---|
1002 | { |
---|
1003 | # Ignore properties that do not apply to |
---|
1004 | # directories. |
---|
1005 | if ($source_type eq 'd') |
---|
1006 | { |
---|
1007 | if ($property_name eq 'svn:eol-style' or |
---|
1008 | $property_name eq 'svn:executable' or |
---|
1009 | $property_name eq 'svn:keywords' or |
---|
1010 | $property_name eq 'svn:mime-type') |
---|
1011 | { |
---|
1012 | next; |
---|
1013 | } |
---|
1014 | } |
---|
1015 | |
---|
1016 | # Ignore properties that do not apply to |
---|
1017 | # files. |
---|
1018 | if ($source_type eq 'f') |
---|
1019 | { |
---|
1020 | if ($property_name eq 'svn:externals' or |
---|
1021 | $property_name eq 'svn:ignore') |
---|
1022 | { |
---|
1023 | next; |
---|
1024 | } |
---|
1025 | } |
---|
1026 | |
---|
1027 | print "Adding to '$source_path' property ", |
---|
1028 | "'$property_name' with value ", |
---|
1029 | "'$property_value'.\n"; |
---|
1030 | |
---|
1031 | push(@{$add_files{$source_path}{properties}}, |
---|
1032 | $property); |
---|
1033 | } |
---|
1034 | |
---|
1035 | last if $property->{control} eq 'break'; |
---|
1036 | } |
---|
1037 | } |
---|
1038 | } |
---|
1039 | |
---|
1040 | # Add svn:executable to files that have their executable bit |
---|
1041 | # set. |
---|
1042 | if ($source_is_exe and !$opt_no_auto_exe) |
---|
1043 | { |
---|
1044 | print "Adding to '$source_path' property 'svn:executable' with ", |
---|
1045 | "value '*'.\n"; |
---|
1046 | my $property = {name => 'svn:executable', value => '*'}; |
---|
1047 | push (@{$add_files{$source_path}{properties}}, |
---|
1048 | $property); |
---|
1049 | } |
---|
1050 | |
---|
1051 | # Now make sure the file or directory in the source directory |
---|
1052 | # exists in the repository. |
---|
1053 | if ($source_type eq 'd') |
---|
1054 | { |
---|
1055 | if ($dest_type eq '0') |
---|
1056 | { |
---|
1057 | mkdir($dest_path) |
---|
1058 | or die "$0: cannot mkdir '$dest_path': $!\n"; |
---|
1059 | } |
---|
1060 | } |
---|
1061 | elsif |
---|
1062 | ($source_type eq 'l') { |
---|
1063 | my $link_target = readlink($source_path) |
---|
1064 | or die "$0: cannot readlink '$source_path': $!\n"; |
---|
1065 | if ($dest_type eq 'l') |
---|
1066 | { |
---|
1067 | my $old_target = readlink($dest_path) |
---|
1068 | or die "$0: cannot readlink '$dest_path': $!\n"; |
---|
1069 | return if ($old_target eq $link_target); |
---|
1070 | unlink($dest_path) |
---|
1071 | or die "$0: unlink '$dest_path' failed: $!\n"; |
---|
1072 | } |
---|
1073 | symlink($link_target, $dest_path) |
---|
1074 | or die "$0: cannot symlink '$dest_path' to '$link_target': $!\n"; |
---|
1075 | } |
---|
1076 | elsif |
---|
1077 | ($source_type eq 'f') { |
---|
1078 | # Only copy the file if the digests do not match. |
---|
1079 | if ($add_files{$source_path} or $upd_files{$source_path}) |
---|
1080 | { |
---|
1081 | copy($source_path, $dest_path) |
---|
1082 | or die "$0: copy '$source_path' to '$dest_path': $!\n"; |
---|
1083 | } |
---|
1084 | } |
---|
1085 | else |
---|
1086 | { |
---|
1087 | die "$0: does not handle copying files of type '$source_type'.\n"; |
---|
1088 | } |
---|
1089 | }; |
---|
1090 | |
---|
1091 | # Now change into the directory containing the files to load. |
---|
1092 | # First change to the original directory where this script was run |
---|
1093 | # so that if the specified directory is a relative directory path, |
---|
1094 | # then the script can change into it. |
---|
1095 | chdir($orig_cwd) |
---|
1096 | or die "$0: cannot chdir '$orig_cwd': $!\n"; |
---|
1097 | chdir($load_dir) |
---|
1098 | or die "$0: cannot chdir '$load_dir': $!\n"; |
---|
1099 | |
---|
1100 | find({no_chdir => 1, |
---|
1101 | preprocess => sub { sort { $b cmp $a } |
---|
1102 | grep { $_ !~ /^[._]svn$/ } @_ }, |
---|
1103 | wanted => $wanted |
---|
1104 | }, '.'); |
---|
1105 | |
---|
1106 | # The files and directories that are in %del_files are the files |
---|
1107 | # and directories that need to be deleted. Because svn will |
---|
1108 | # return an error if a file or directory is deleted in a directory |
---|
1109 | # that subsequently is deleted, first find all directories and |
---|
1110 | # remove from the list any files and directories inside those |
---|
1111 | # directories from this list. Work through the list repeatedly |
---|
1112 | # working from short to long names so that directories containing |
---|
1113 | # other files and directories will be deleted first. |
---|
1114 | my $repeat_loop; |
---|
1115 | do |
---|
1116 | { |
---|
1117 | $repeat_loop = 0; |
---|
1118 | my @del_files = sort {length($a) <=> length($b) || $a cmp $b} |
---|
1119 | keys %del_files; |
---|
1120 | &filter_renamed_files(\@del_files, \%rename_from_files); |
---|
1121 | foreach my $file (@del_files) |
---|
1122 | { |
---|
1123 | if ($del_files{$file}{type} eq 'd') |
---|
1124 | { |
---|
1125 | my $dir = "$file/"; |
---|
1126 | my $dir_length = length($dir); |
---|
1127 | foreach my $f (@del_files) |
---|
1128 | { |
---|
1129 | next if $file eq $f; |
---|
1130 | if (length($f) >= $dir_length and |
---|
1131 | substr($f, 0, $dir_length) eq $dir) |
---|
1132 | { |
---|
1133 | print "d $f\n"; |
---|
1134 | delete $del_files{$f}; |
---|
1135 | $repeat_loop = 1; |
---|
1136 | } |
---|
1137 | } |
---|
1138 | |
---|
1139 | # If there were any deletions of files and/or |
---|
1140 | # directories inside a directory that will be deleted, |
---|
1141 | # then restart the entire loop again, because one or |
---|
1142 | # more keys have been deleted from %del_files. |
---|
1143 | # Equally important is not to stop this loop if no |
---|
1144 | # deletions have been done, otherwise later |
---|
1145 | # directories that may contain files and directories |
---|
1146 | # to be deleted will not be deleted. |
---|
1147 | last if $repeat_loop; |
---|
1148 | } |
---|
1149 | } |
---|
1150 | } while ($repeat_loop); |
---|
1151 | |
---|
1152 | # What is left are files that are not in any directories to be |
---|
1153 | # deleted and directories to be deleted. To delete the files, |
---|
1154 | # deeper files and directories must be deleted first. Because we |
---|
1155 | # have a hash keyed by remaining files and directories to be |
---|
1156 | # deleted, instead of trying to figure out which directories and |
---|
1157 | # files are contained in other directories, just reverse sort by |
---|
1158 | # the path length and then alphabetically. |
---|
1159 | my @del_files = sort {length($b) <=> length($a) || $a cmp $b } |
---|
1160 | keys %del_files; |
---|
1161 | &filter_renamed_files(\@del_files, \%rename_from_files); |
---|
1162 | foreach my $file (@del_files) |
---|
1163 | { |
---|
1164 | print "D $file\n"; |
---|
1165 | } |
---|
1166 | |
---|
1167 | # Now change back to the trunk directory and run the svn commands. |
---|
1168 | chdir($wc_import_dir_cwd) |
---|
1169 | or die "$0: cannot chdir '$wc_import_dir_cwd': $!\n"; |
---|
1170 | |
---|
1171 | # If any of the added files have the svn:eol-style property set, |
---|
1172 | # then pass -b to diff, otherwise diff may fail because the end of |
---|
1173 | # lines have changed and the source file and file in the |
---|
1174 | # repository will not be identical. |
---|
1175 | my @diff_ignore_space_changes; |
---|
1176 | |
---|
1177 | if (keys %add_files) |
---|
1178 | { |
---|
1179 | my @add_files = sort {length($a) <=> length($b) || $a cmp $b} |
---|
1180 | keys %add_files; |
---|
1181 | my $target_filename = &make_targets_file(@add_files); |
---|
1182 | read_from_process($svn, 'add', '-N', '--targets', $target_filename); |
---|
1183 | unlink($target_filename); |
---|
1184 | |
---|
1185 | # Add properties on the added files. |
---|
1186 | foreach my $add_file (@add_files) |
---|
1187 | { |
---|
1188 | foreach my $property (@{$add_files{$add_file}{properties}}) |
---|
1189 | { |
---|
1190 | my $property_name = $property->{name}; |
---|
1191 | my $property_value = $property->{value}; |
---|
1192 | |
---|
1193 | if ($property_name eq 'svn:eol-style') |
---|
1194 | { |
---|
1195 | @diff_ignore_space_changes = ('-b'); |
---|
1196 | } |
---|
1197 | |
---|
1198 | # Write the value to a temporary file in case it's multi-line |
---|
1199 | my ($handle, $tmpfile) = tempfile(DIR => $temp_dir); |
---|
1200 | print $handle $property_value; |
---|
1201 | close($handle); |
---|
1202 | |
---|
1203 | read_from_process($svn, |
---|
1204 | 'propset', |
---|
1205 | $property_name, |
---|
1206 | '--file', |
---|
1207 | $tmpfile, |
---|
1208 | $add_file); |
---|
1209 | } |
---|
1210 | } |
---|
1211 | } |
---|
1212 | if (@del_files) |
---|
1213 | { |
---|
1214 | my $target_filename = &make_targets_file(@del_files); |
---|
1215 | read_from_process($svn, 'rm', '--targets', $target_filename); |
---|
1216 | unlink($target_filename); |
---|
1217 | } |
---|
1218 | |
---|
1219 | # Go through the list of updated files and check the svn:eol-style |
---|
1220 | # property. If it is set to native, then convert all CR, CRLF and |
---|
1221 | # LF's in the file to the native end of line characters. Also, |
---|
1222 | # modify diff's command line so that it will ignore the change in |
---|
1223 | # end of line style. |
---|
1224 | if (keys %upd_files) |
---|
1225 | { |
---|
1226 | my @upd_files = sort {length($a) <=> length($b) || $a cmp $b} |
---|
1227 | keys %upd_files; |
---|
1228 | foreach my $upd_file (@upd_files) |
---|
1229 | { |
---|
1230 | # Always append @BASE to a filename in case they contain a |
---|
1231 | # @ character, in which case the Subversion command line |
---|
1232 | # client will attempt to parse the characters after the @ |
---|
1233 | # as a revision and most likely fail, or if the characters |
---|
1234 | # after the @ are a valid revision, then it'll possibly |
---|
1235 | # get the incorrect information. So always append @BASE |
---|
1236 | # and any preceding @'s will be treated normally and the |
---|
1237 | # correct information will be retrieved. |
---|
1238 | my @command = ($svn, |
---|
1239 | 'propget', |
---|
1240 | 'svn:eol-style', |
---|
1241 | "$upd_file\@BASE"); |
---|
1242 | my @lines = read_from_process(@command); |
---|
1243 | next unless @lines; |
---|
1244 | if (@lines > 1) |
---|
1245 | { |
---|
1246 | warn "$0: '@command' returned more than one line of output: ", |
---|
1247 | "'@lines'.\n"; |
---|
1248 | next; |
---|
1249 | } |
---|
1250 | |
---|
1251 | my $eol_style = $lines[0]; |
---|
1252 | if ($eol_style eq 'native') |
---|
1253 | { |
---|
1254 | @diff_ignore_space_changes = ('-b'); |
---|
1255 | if (&convert_file_to_native_eol($upd_file)) |
---|
1256 | { |
---|
1257 | print "Native eol-style conversion modified $upd_file.\n"; |
---|
1258 | } |
---|
1259 | } |
---|
1260 | } |
---|
1261 | } |
---|
1262 | |
---|
1263 | my $message = wrap('', '', "Load $load_dir into $repos_load_abs_path.\n"); |
---|
1264 | read_from_process($svn, 'commit', |
---|
1265 | @svn_use_repos_cmd_opts, |
---|
1266 | '-m', $message); |
---|
1267 | |
---|
1268 | # If an update is not run now after a commit, then some file and |
---|
1269 | # directory paths will have an older revisions associated with |
---|
1270 | # them and any future commits will fail because they are out of |
---|
1271 | # date. |
---|
1272 | read_from_process($svn, 'update', @svn_use_repos_cmd_opts); |
---|
1273 | |
---|
1274 | # Now remove any files and directories to be deleted in the |
---|
1275 | # repository. |
---|
1276 | if (@del_files) |
---|
1277 | { |
---|
1278 | rmtree(\@del_files, 1, 0); |
---|
1279 | } |
---|
1280 | |
---|
1281 | # Now make the tag by doing a copy in the svn repository itself. |
---|
1282 | if (defined $load_tag) |
---|
1283 | { |
---|
1284 | my $repos_tag_abs_path = length($repos_base_path_segment) ? |
---|
1285 | "$repos_base_path_segment/$load_tag" : |
---|
1286 | $load_tag; |
---|
1287 | |
---|
1288 | my $from_url = $repos_load_rel_path eq '.' ? |
---|
1289 | $repos_load_rel_path : |
---|
1290 | "$repos_base_url/$repos_load_rel_path"; |
---|
1291 | my $to_url = "$repos_base_url/$load_tag"; |
---|
1292 | |
---|
1293 | $message = wrap("", |
---|
1294 | "", |
---|
1295 | "Tag $repos_load_abs_path as " . |
---|
1296 | "$repos_tag_abs_path.\n"); |
---|
1297 | read_from_process($svn, 'cp', @svn_use_repos_cmd_opts, |
---|
1298 | '-m', $message, $from_url, $to_url); |
---|
1299 | |
---|
1300 | # Now check out the tag and run a recursive diff between the |
---|
1301 | # original source directory and the tag for a consistency |
---|
1302 | # check. |
---|
1303 | my $checkout_dir_name = "my_tag_wc_named_$load_tag"; |
---|
1304 | print "Checking out $to_url into $temp_dir/$checkout_dir_name\n"; |
---|
1305 | |
---|
1306 | chdir($temp_dir) |
---|
1307 | or die "$0: cannot chdir '$temp_dir': $!\n"; |
---|
1308 | |
---|
1309 | read_from_process($svn, 'checkout', |
---|
1310 | @svn_use_repos_cmd_opts, |
---|
1311 | $to_url, $checkout_dir_name); |
---|
1312 | |
---|
1313 | chdir($checkout_dir_name) |
---|
1314 | or die "$0: cannot chdir '$checkout_dir_name': $!\n"; |
---|
1315 | |
---|
1316 | chdir($orig_cwd) |
---|
1317 | or die "$0: cannot chdir '$orig_cwd': $!\n"; |
---|
1318 | read_from_process('diff', '-u', @diff_ignore_space_changes, |
---|
1319 | '-x', '.svn', |
---|
1320 | '-r', $load_dir, "$temp_dir/$checkout_dir_name"); |
---|
1321 | } |
---|
1322 | } |
---|
1323 | |
---|
1324 | exit 0; |
---|
1325 | |
---|
1326 | sub usage |
---|
1327 | { |
---|
1328 | warn "@_\n" if @_; |
---|
1329 | die "usage: $0 [options] svn_url svn_import_dir [dir_v1 [dir_v2 [..]]]\n", |
---|
1330 | " svn_url is the file:// or http:// URL of the svn repository\n", |
---|
1331 | " svn_import_dir is the path relative to svn_url where to load dirs\n", |
---|
1332 | " dir_v1 .. list dirs to import otherwise read from stdin\n", |
---|
1333 | "options are\n", |
---|
1334 | " -no_user_input don't ask yes/no questions and assume yes answer\n", |
---|
1335 | " -no_auto_exe don't set svn:executable for executable files\n", |
---|
1336 | " -p filename table listing properties to apply to matching files\n", |
---|
1337 | " -svn_username username to perform commits as\n", |
---|
1338 | " -svn_password password to supply to svn commit\n", |
---|
1339 | " -t tag_dir create a tag copy in tag_dir, relative to svn_url\n", |
---|
1340 | " -v increase program verbosity, multiple -v's allowed\n", |
---|
1341 | " -wc path use the already checked-out working copy at path\n", |
---|
1342 | " instead of checkout out a fresh working copy\n", |
---|
1343 | " -glob_ignores List of filename patterns to ignore (as in svn's\n", |
---|
1344 | " global-ignores config option)\n"; |
---|
1345 | } |
---|
1346 | |
---|
1347 | # Get the next directory to load, either from the command line or from |
---|
1348 | # standard input. |
---|
1349 | my $get_next_load_dir_init = 0; |
---|
1350 | my @get_next_load_dirs; |
---|
1351 | sub get_next_load_dir |
---|
1352 | { |
---|
1353 | if (@ARGV) |
---|
1354 | { |
---|
1355 | unless ($get_next_load_dir_init) |
---|
1356 | { |
---|
1357 | $get_next_load_dir_init = 1; |
---|
1358 | @get_next_load_dirs = @ARGV; |
---|
1359 | } |
---|
1360 | return shift @get_next_load_dirs; |
---|
1361 | } |
---|
1362 | |
---|
1363 | if ($opt_verbose) |
---|
1364 | { |
---|
1365 | print "Waiting for next directory to import on standard input:\n"; |
---|
1366 | } |
---|
1367 | my $line = <STDIN>; |
---|
1368 | |
---|
1369 | print "\n" if $opt_verbose; |
---|
1370 | |
---|
1371 | chomp $line; |
---|
1372 | if ($line =~ m|(\S+)\s+(\S+)|) |
---|
1373 | { |
---|
1374 | $line = $1; |
---|
1375 | set_svn_use_repos_cmd_opts($2, $opt_svn_password); |
---|
1376 | } |
---|
1377 | $line; |
---|
1378 | } |
---|
1379 | |
---|
1380 | # This constant stores the commonly used string to indicate that a |
---|
1381 | # subroutine has been passed an incorrect number of arguments. |
---|
1382 | use vars qw($INCORRECT_NUMBER_OF_ARGS); |
---|
1383 | $INCORRECT_NUMBER_OF_ARGS = "passed incorrect number of arguments.\n"; |
---|
1384 | |
---|
1385 | # Creates a temporary file in the temporary directory and stores the |
---|
1386 | # arguments in it for use by the svn --targets command line option. |
---|
1387 | # If any part of the file creation failed, exit the program, as |
---|
1388 | # there's no workaround. Use a unique number as a counter to the |
---|
1389 | # files. |
---|
1390 | my $make_targets_file_counter; |
---|
1391 | sub make_targets_file |
---|
1392 | { |
---|
1393 | unless (@_) |
---|
1394 | { |
---|
1395 | confess "$0: make_targets_file $INCORRECT_NUMBER_OF_ARGS"; |
---|
1396 | } |
---|
1397 | |
---|
1398 | $make_targets_file_counter = 1 unless defined $make_targets_file_counter; |
---|
1399 | |
---|
1400 | my $filename = sprintf "%s/targets.%05d", |
---|
1401 | $temp_dir, |
---|
1402 | $make_targets_file_counter; |
---|
1403 | ++$make_targets_file_counter; |
---|
1404 | |
---|
1405 | open(TARGETS, ">$filename") |
---|
1406 | or die "$0: cannot open '$filename' for writing: $!\n"; |
---|
1407 | |
---|
1408 | foreach my $file (@_) |
---|
1409 | { |
---|
1410 | print TARGETS "$file\n"; |
---|
1411 | } |
---|
1412 | |
---|
1413 | close(TARGETS) |
---|
1414 | or die "$0: error in closing '$filename' for writing: $!\n"; |
---|
1415 | |
---|
1416 | $filename; |
---|
1417 | } |
---|
1418 | |
---|
1419 | # Set the svn command line options that are used anytime svn connects |
---|
1420 | # to the repository. |
---|
1421 | sub set_svn_use_repos_cmd_opts |
---|
1422 | { |
---|
1423 | unless (@_ == 2) |
---|
1424 | { |
---|
1425 | confess "$0: set_svn_use_repos_cmd_opts $INCORRECT_NUMBER_OF_ARGS"; |
---|
1426 | } |
---|
1427 | |
---|
1428 | my $username = shift; |
---|
1429 | my $password = shift; |
---|
1430 | |
---|
1431 | @svn_use_repos_cmd_opts = ('--non-interactive'); |
---|
1432 | if (defined $username and length $username) |
---|
1433 | { |
---|
1434 | push(@svn_use_repos_cmd_opts, '--username', $username); |
---|
1435 | } |
---|
1436 | if (defined $password) |
---|
1437 | { |
---|
1438 | push(@svn_use_repos_cmd_opts, '--password', $password); |
---|
1439 | } |
---|
1440 | } |
---|
1441 | |
---|
1442 | sub get_tag_dir |
---|
1443 | { |
---|
1444 | unless (@_ == 1) |
---|
1445 | { |
---|
1446 | confess "$0: get_tag_dir $INCORRECT_NUMBER_OF_ARGS"; |
---|
1447 | } |
---|
1448 | |
---|
1449 | my $load_dir = shift; |
---|
1450 | |
---|
1451 | # Take the tag relative directory, search for pairs of |
---|
1452 | # REGEX_SEP_CHAR's and use the regular expression inside the pair to |
---|
1453 | # put in the tag directory name. |
---|
1454 | my $tag_location = $opt_import_tag_location; |
---|
1455 | my $load_tag = ''; |
---|
1456 | while ((my $i = index($tag_location, $REGEX_SEP_CHAR)) >= 0) |
---|
1457 | { |
---|
1458 | $load_tag .= substr($tag_location, 0, $i, ''); |
---|
1459 | substr($tag_location, 0, 1, ''); |
---|
1460 | my $j = index($tag_location, $REGEX_SEP_CHAR); |
---|
1461 | if ($j < 0) |
---|
1462 | { |
---|
1463 | die "$0: -t value '$opt_import_tag_location' does not have ", |
---|
1464 | "matching $REGEX_SEP_CHAR.\n"; |
---|
1465 | } |
---|
1466 | my $regex = substr($tag_location, 0, $j, ''); |
---|
1467 | $regex = "($regex)" unless ($regex =~ /\(.+\)/); |
---|
1468 | substr($tag_location, 0, 1, ''); |
---|
1469 | my @results = $load_dir =~ m/$regex/; |
---|
1470 | $load_tag .= join('', @results); |
---|
1471 | } |
---|
1472 | $load_tag .= $tag_location; |
---|
1473 | |
---|
1474 | $load_tag; |
---|
1475 | } |
---|
1476 | |
---|
1477 | # Return a two element array. The first element is a single character |
---|
1478 | # that represents the type of object the path points to. The second |
---|
1479 | # is a boolean (1 for true, '' for false) if the path points to a file |
---|
1480 | # and if the file is executable. |
---|
1481 | sub file_info |
---|
1482 | { |
---|
1483 | lstat(shift) or return ('0', ''); |
---|
1484 | -b _ and return ('b', ''); |
---|
1485 | -c _ and return ('c', ''); |
---|
1486 | -d _ and return ('d', ''); |
---|
1487 | -f _ and return ('f', -x _); |
---|
1488 | -l _ and return ('l', ''); |
---|
1489 | -p _ and return ('p', ''); |
---|
1490 | -S _ and return ('S', ''); |
---|
1491 | return '?'; |
---|
1492 | } |
---|
1493 | |
---|
1494 | # Start a child process safely without using /bin/sh. |
---|
1495 | sub safe_read_from_pipe |
---|
1496 | { |
---|
1497 | unless (@_) |
---|
1498 | { |
---|
1499 | croak "$0: safe_read_from_pipe $INCORRECT_NUMBER_OF_ARGS"; |
---|
1500 | } |
---|
1501 | |
---|
1502 | my $openfork_available = "MSWin32" ne $OSNAME; |
---|
1503 | if ($openfork_available) |
---|
1504 | { |
---|
1505 | print "Running @_\n"; |
---|
1506 | my $pid = open(SAFE_READ, "-|"); |
---|
1507 | unless (defined $pid) |
---|
1508 | { |
---|
1509 | die "$0: cannot fork: $!\n"; |
---|
1510 | } |
---|
1511 | unless ($pid) |
---|
1512 | { |
---|
1513 | # child |
---|
1514 | open(STDERR, ">&STDOUT") |
---|
1515 | or die "$0: cannot dup STDOUT: $!\n"; |
---|
1516 | exec(@_) |
---|
1517 | or die "$0: cannot exec '@_': $!\n"; |
---|
1518 | } |
---|
1519 | } |
---|
1520 | else |
---|
1521 | { |
---|
1522 | # Redirect the comment into a temp file and use that to work around |
---|
1523 | # Windoze's (non-)handling of multi-line commands. |
---|
1524 | my @commandline = (); |
---|
1525 | my $command; |
---|
1526 | my $comment; |
---|
1527 | |
---|
1528 | while ($command = shift) |
---|
1529 | { |
---|
1530 | if ("-m" eq $command) |
---|
1531 | { |
---|
1532 | my $comment = shift; |
---|
1533 | my ($handle, $tmpfile) = tempfile(DIR => $temp_dir); |
---|
1534 | print $handle $comment; |
---|
1535 | close($handle); |
---|
1536 | |
---|
1537 | push(@commandline, "--file"); |
---|
1538 | push(@commandline, $tmpfile); |
---|
1539 | } |
---|
1540 | else |
---|
1541 | { |
---|
1542 | # Munge the command to protect it from the command line |
---|
1543 | $command =~ s/\"/\\\"/g; |
---|
1544 | if ($command =~ m"\s") { $command = "\"$command\""; } |
---|
1545 | if ($command eq "") { $command = "\"\""; } |
---|
1546 | if ($command =~ m"\n") |
---|
1547 | { |
---|
1548 | warn "$0: carriage return detected in command - may not work\n"; |
---|
1549 | } |
---|
1550 | push(@commandline, $command); |
---|
1551 | } |
---|
1552 | } |
---|
1553 | |
---|
1554 | print "Running @commandline\n"; |
---|
1555 | if ( $comment ) { print $comment; } |
---|
1556 | |
---|
1557 | # Now do the pipe. |
---|
1558 | open(SAFE_READ, "@commandline |") |
---|
1559 | or die "$0: cannot pipe to command: $!\n"; |
---|
1560 | } |
---|
1561 | |
---|
1562 | # parent |
---|
1563 | my @output; |
---|
1564 | while (<SAFE_READ>) |
---|
1565 | { |
---|
1566 | chomp; |
---|
1567 | push(@output, $_); |
---|
1568 | } |
---|
1569 | close(SAFE_READ); |
---|
1570 | my $result = $?; |
---|
1571 | my $exit = $result >> 8; |
---|
1572 | my $signal = $result & 127; |
---|
1573 | my $cd = $result & 128 ? "with core dump" : ""; |
---|
1574 | if ($signal or $cd) |
---|
1575 | { |
---|
1576 | warn "$0: pipe from '@_' failed $cd: exit=$exit signal=$signal\n"; |
---|
1577 | } |
---|
1578 | if (wantarray) |
---|
1579 | { |
---|
1580 | return ($result, @output); |
---|
1581 | } |
---|
1582 | else |
---|
1583 | { |
---|
1584 | return $result; |
---|
1585 | } |
---|
1586 | } |
---|
1587 | |
---|
1588 | # Use safe_read_from_pipe to start a child process safely and exit the |
---|
1589 | # script if the child failed for whatever reason. |
---|
1590 | sub read_from_process |
---|
1591 | { |
---|
1592 | unless (@_) |
---|
1593 | { |
---|
1594 | croak "$0: read_from_process $INCORRECT_NUMBER_OF_ARGS"; |
---|
1595 | } |
---|
1596 | my ($status, @output) = &safe_read_from_pipe(@_); |
---|
1597 | if ($status) |
---|
1598 | { |
---|
1599 | print STDERR "$0: @_ failed with this output:\n", join("\n", @output), |
---|
1600 | "\n"; |
---|
1601 | unless ($opt_no_user_input) |
---|
1602 | { |
---|
1603 | print STDERR |
---|
1604 | "Press return to quit and clean up svn working directory: "; |
---|
1605 | <STDIN>; |
---|
1606 | } |
---|
1607 | exit 1; |
---|
1608 | } |
---|
1609 | else |
---|
1610 | { |
---|
1611 | return @output; |
---|
1612 | } |
---|
1613 | } |
---|
1614 | |
---|
1615 | # Get a list of all the files and directories in the specified |
---|
1616 | # directory, the type of file and a digest hash of file types. |
---|
1617 | sub recursive_ls_and_hash |
---|
1618 | { |
---|
1619 | unless (@_ == 1) |
---|
1620 | { |
---|
1621 | croak "$0: recursive_ls_and_hash $INCORRECT_NUMBER_OF_ARGS"; |
---|
1622 | } |
---|
1623 | |
---|
1624 | # This is the directory to change into. |
---|
1625 | my $dir = shift; |
---|
1626 | |
---|
1627 | # Get the current directory so that the script can change into the |
---|
1628 | # current working directory after changing into the specified |
---|
1629 | # directory. |
---|
1630 | my $return_cwd = cwd; |
---|
1631 | |
---|
1632 | chdir($dir) |
---|
1633 | or die "$0: cannot chdir '$dir': $!\n"; |
---|
1634 | |
---|
1635 | my %files; |
---|
1636 | |
---|
1637 | my $wanted = sub |
---|
1638 | { |
---|
1639 | s#^\./##; |
---|
1640 | return if $_ eq '.'; |
---|
1641 | my ($file_type) = &file_info($_); |
---|
1642 | my $file_digest; |
---|
1643 | if ($file_type eq 'f' or ($file_type eq 'l' and stat($_) and -f _)) |
---|
1644 | { |
---|
1645 | $file_digest = &digest_hash_file($_); |
---|
1646 | } |
---|
1647 | $files{$_} = {type => $file_type, |
---|
1648 | digest => $file_digest}; |
---|
1649 | }; |
---|
1650 | find({no_chdir => 1, |
---|
1651 | preprocess => sub |
---|
1652 | { |
---|
1653 | grep |
---|
1654 | { |
---|
1655 | my $ok=1; |
---|
1656 | foreach my $x (@glob_ignores) |
---|
1657 | { |
---|
1658 | if ( $_ =~ /$x/ ) {$ok=0;last;} |
---|
1659 | } |
---|
1660 | $ok |
---|
1661 | } @_ |
---|
1662 | }, |
---|
1663 | wanted => $wanted |
---|
1664 | }, '.'); |
---|
1665 | |
---|
1666 | chdir($return_cwd) |
---|
1667 | or die "$0: cannot chdir '$return_cwd': $!\n"; |
---|
1668 | |
---|
1669 | %files; |
---|
1670 | } |
---|
1671 | |
---|
1672 | # Given a list of files and directories which have been renamed but |
---|
1673 | # not commtited, commit them with a proper log message. |
---|
1674 | sub commit_renames |
---|
1675 | { |
---|
1676 | unless (@_ == 4) |
---|
1677 | { |
---|
1678 | croak "$0: commit_renames $INCORRECT_NUMBER_OF_ARGS"; |
---|
1679 | } |
---|
1680 | |
---|
1681 | my $load_dir = shift; |
---|
1682 | my $renamed_filenames = shift; |
---|
1683 | my $rename_from_files = shift; |
---|
1684 | my $rename_to_files = shift; |
---|
1685 | |
---|
1686 | my $number_renames = @$renamed_filenames/2; |
---|
1687 | |
---|
1688 | my $message = "To prepare to load $load_dir into $repos_load_abs_path, " . |
---|
1689 | "perform $number_renames rename" . |
---|
1690 | ($number_renames > 1 ? "s" : "") . ".\n"; |
---|
1691 | |
---|
1692 | # Text::Wrap::wrap appears to replace multiple consecutive \n's with |
---|
1693 | # one \n, so wrap the text and then append the second \n. |
---|
1694 | $message = wrap("", "", $message) . "\n"; |
---|
1695 | while (@$renamed_filenames) |
---|
1696 | { |
---|
1697 | my $from = "$repos_load_abs_path/" . shift @$renamed_filenames; |
---|
1698 | my $to = "$repos_load_abs_path/" . shift @$renamed_filenames; |
---|
1699 | $message .= wrap("", " ", "* $to: Renamed from $from.\n"); |
---|
1700 | } |
---|
1701 | |
---|
1702 | # Change to the top of the working copy so that any |
---|
1703 | # directories will also be updated. |
---|
1704 | my $cwd = cwd; |
---|
1705 | chdir($wc_import_dir_cwd) |
---|
1706 | or die "$0: cannot chdir '$wc_import_dir_cwd': $!\n"; |
---|
1707 | read_from_process($svn, 'commit', @svn_use_repos_cmd_opts, '-m', $message); |
---|
1708 | read_from_process($svn, 'update', @svn_use_repos_cmd_opts); |
---|
1709 | chdir($cwd) |
---|
1710 | or die "$0: cannot chdir '$cwd': $!\n"; |
---|
1711 | |
---|
1712 | # Some versions of subversion have a bug where renamed files |
---|
1713 | # or directories are not deleted after a commit, so do that |
---|
1714 | # here. |
---|
1715 | my @del_files = sort {length($b) <=> length($a) || $a cmp $b } |
---|
1716 | keys %$rename_from_files; |
---|
1717 | rmtree(\@del_files, 1, 0); |
---|
1718 | |
---|
1719 | # Empty the list of old and new renamed names. |
---|
1720 | undef %$rename_from_files; |
---|
1721 | undef %$rename_to_files; |
---|
1722 | } |
---|
1723 | |
---|
1724 | # Take a one file or directory and see if its name is equal to a |
---|
1725 | # second or is contained in the second if the second file's file type |
---|
1726 | # is a directory. |
---|
1727 | sub contained_in |
---|
1728 | { |
---|
1729 | unless (@_ == 3) |
---|
1730 | { |
---|
1731 | croak "$0: contain_in $INCORRECT_NUMBER_OF_ARGS"; |
---|
1732 | } |
---|
1733 | |
---|
1734 | my $contained = shift; |
---|
1735 | my $container = shift; |
---|
1736 | my $container_type = shift; |
---|
1737 | |
---|
1738 | if ($container eq $contained) |
---|
1739 | { |
---|
1740 | return 1; |
---|
1741 | } |
---|
1742 | |
---|
1743 | if ($container_type eq 'd') |
---|
1744 | { |
---|
1745 | my $dirname = "$container/"; |
---|
1746 | my $dirname_length = length($dirname); |
---|
1747 | |
---|
1748 | if ($dirname_length <= length($contained) and |
---|
1749 | $dirname eq substr($contained, 0, $dirname_length)) |
---|
1750 | { |
---|
1751 | return 1; |
---|
1752 | } |
---|
1753 | } |
---|
1754 | |
---|
1755 | return 0; |
---|
1756 | } |
---|
1757 | |
---|
1758 | # Take an array reference containing a list of files and directories |
---|
1759 | # and take a hash reference and remove from the array reference any |
---|
1760 | # files and directories and the files the directory contains listed in |
---|
1761 | # the hash. |
---|
1762 | sub filter_renamed_files |
---|
1763 | { |
---|
1764 | unless (@_ == 2) |
---|
1765 | { |
---|
1766 | croak "$0: filter_renamed_files $INCORRECT_NUMBER_OF_ARGS"; |
---|
1767 | } |
---|
1768 | |
---|
1769 | my $array_ref = shift; |
---|
1770 | my $hash_ref = shift; |
---|
1771 | |
---|
1772 | foreach my $remove_filename (keys %$hash_ref) |
---|
1773 | { |
---|
1774 | my $remove_file_type = $hash_ref->{$remove_filename}{type}; |
---|
1775 | for (my $i=0; $i<@$array_ref;) |
---|
1776 | { |
---|
1777 | if (contained_in($array_ref->[$i], |
---|
1778 | $remove_filename, |
---|
1779 | $remove_file_type)) |
---|
1780 | { |
---|
1781 | splice(@$array_ref, $i, 1); |
---|
1782 | next; |
---|
1783 | } |
---|
1784 | ++$i; |
---|
1785 | } |
---|
1786 | } |
---|
1787 | } |
---|
1788 | |
---|
1789 | # Get a digest hash of the specified filename. |
---|
1790 | sub digest_hash_file |
---|
1791 | { |
---|
1792 | unless (@_ == 1) |
---|
1793 | { |
---|
1794 | croak "$0: digest_hash_file $INCORRECT_NUMBER_OF_ARGS"; |
---|
1795 | } |
---|
1796 | |
---|
1797 | my $filename = shift; |
---|
1798 | |
---|
1799 | my $ctx = Digest::MD5->new; |
---|
1800 | if (open(READ, $filename)) |
---|
1801 | { |
---|
1802 | binmode READ; |
---|
1803 | $ctx->addfile(*READ); |
---|
1804 | close(READ); |
---|
1805 | } |
---|
1806 | else |
---|
1807 | { |
---|
1808 | die "$0: cannot open '$filename' for reading: $!\n"; |
---|
1809 | } |
---|
1810 | $ctx->digest; |
---|
1811 | } |
---|
1812 | |
---|
1813 | # Read standard input until a line contains the required input or an |
---|
1814 | # empty line to signify the default answer. |
---|
1815 | sub get_answer |
---|
1816 | { |
---|
1817 | unless (@_ == 3) |
---|
1818 | { |
---|
1819 | croak "$0: get_answer $INCORRECT_NUMBER_OF_ARGS"; |
---|
1820 | } |
---|
1821 | |
---|
1822 | my $message = shift; |
---|
1823 | my $answers = shift; |
---|
1824 | my $def_ans = shift; |
---|
1825 | |
---|
1826 | return $def_ans if $opt_no_user_input; |
---|
1827 | |
---|
1828 | my $char; |
---|
1829 | do |
---|
1830 | { |
---|
1831 | print $message; |
---|
1832 | $char = ''; |
---|
1833 | my $line = <STDIN>; |
---|
1834 | if (defined $line and length $line) |
---|
1835 | { |
---|
1836 | $char = substr($line, 0, 1); |
---|
1837 | $char = '' if $char eq "\n"; |
---|
1838 | } |
---|
1839 | } until $char eq '' or $answers =~ /$char/ig; |
---|
1840 | |
---|
1841 | return $def_ans if $char eq ''; |
---|
1842 | return pos($answers) - 1; |
---|
1843 | } |
---|
1844 | |
---|
1845 | # Determine the native end of line on this system by writing a \n in |
---|
1846 | # non-binary mode to an empty file and reading the same file back in |
---|
1847 | # binary mode. |
---|
1848 | sub determine_native_eol |
---|
1849 | { |
---|
1850 | my $filename = "$temp_dir/svn_load_dirs_eol_test.$$"; |
---|
1851 | if (-e $filename) |
---|
1852 | { |
---|
1853 | unlink($filename) |
---|
1854 | or die "$0: cannot unlink '$filename': $!\n"; |
---|
1855 | } |
---|
1856 | |
---|
1857 | # Write the \n in non-binary mode. |
---|
1858 | open(NL_TEST, ">$filename") |
---|
1859 | or die "$0: cannot open '$filename' for writing: $!\n"; |
---|
1860 | print NL_TEST "\n"; |
---|
1861 | close(NL_TEST) |
---|
1862 | or die "$0: error in closing '$filename' for writing: $!\n"; |
---|
1863 | |
---|
1864 | # Read the \n in binary mode. |
---|
1865 | open(NL_TEST, $filename) |
---|
1866 | or die "$0: cannot open '$filename' for reading: $!\n"; |
---|
1867 | binmode NL_TEST; |
---|
1868 | local $/; |
---|
1869 | undef $/; |
---|
1870 | my $eol = <NL_TEST>; |
---|
1871 | close(NL_TEST) |
---|
1872 | or die "$0: cannot close '$filename' for reading: $!\n"; |
---|
1873 | unlink($filename) |
---|
1874 | or die "$0: cannot unlink '$filename': $!\n"; |
---|
1875 | |
---|
1876 | my $eol_length = length($eol); |
---|
1877 | unless ($eol_length) |
---|
1878 | { |
---|
1879 | die "$0: native eol length on this system is 0.\n"; |
---|
1880 | } |
---|
1881 | |
---|
1882 | print "Native EOL on this system is "; |
---|
1883 | for (my $i=0; $i<$eol_length; ++$i) |
---|
1884 | { |
---|
1885 | printf "\\%03o", ord(substr($eol, $i, 1)); |
---|
1886 | } |
---|
1887 | print ".\n\n"; |
---|
1888 | |
---|
1889 | $eol; |
---|
1890 | } |
---|
1891 | |
---|
1892 | # Take a filename, open the file and replace all CR, CRLF and LF's |
---|
1893 | # with the native end of line style for this system. |
---|
1894 | sub convert_file_to_native_eol |
---|
1895 | { |
---|
1896 | unless (@_ == 1) |
---|
1897 | { |
---|
1898 | croak "$0: convert_file_to_native_eol $INCORRECT_NUMBER_OF_ARGS"; |
---|
1899 | } |
---|
1900 | |
---|
1901 | my $filename = shift; |
---|
1902 | open(FILE, $filename) |
---|
1903 | or die "$0: cannot open '$filename' for reading: $!\n"; |
---|
1904 | binmode FILE; |
---|
1905 | local $/; |
---|
1906 | undef $/; |
---|
1907 | my $in = <FILE>; |
---|
1908 | close(FILE) |
---|
1909 | or die "$0: error in closing '$filename' for reading: $!\n"; |
---|
1910 | my $out = ''; |
---|
1911 | |
---|
1912 | # Go through the file and transform it byte by byte. |
---|
1913 | my $i = 0; |
---|
1914 | while ($i < length($in)) |
---|
1915 | { |
---|
1916 | my $cc = substr($in, $i, 2); |
---|
1917 | if ($cc eq "\015\012") |
---|
1918 | { |
---|
1919 | $out .= $native_eol; |
---|
1920 | $i += 2; |
---|
1921 | next; |
---|
1922 | } |
---|
1923 | |
---|
1924 | my $c = substr($cc, 0, 1); |
---|
1925 | if ($c eq "\012" or $c eq "\015") |
---|
1926 | { |
---|
1927 | $out .= $native_eol; |
---|
1928 | } |
---|
1929 | else |
---|
1930 | { |
---|
1931 | $out .= $c; |
---|
1932 | } |
---|
1933 | ++$i; |
---|
1934 | } |
---|
1935 | |
---|
1936 | return 0 if $in eq $out; |
---|
1937 | |
---|
1938 | my $tmp_filename = ".svn/tmp/svn_load_dirs.$$"; |
---|
1939 | open(FILE, ">$tmp_filename") |
---|
1940 | or die "$0: cannot open '$tmp_filename' for writing: $!\n"; |
---|
1941 | binmode FILE; |
---|
1942 | print FILE $out; |
---|
1943 | close(FILE) |
---|
1944 | or die "$0: cannot close '$tmp_filename' for writing: $!\n"; |
---|
1945 | rename($tmp_filename, $filename) |
---|
1946 | or die "$0: cannot rename '$tmp_filename' to '$filename': $!\n"; |
---|
1947 | |
---|
1948 | return 1; |
---|
1949 | } |
---|
1950 | |
---|
1951 | # Split the input line into words taking into account that single or |
---|
1952 | # double quotes may define a single word with whitespace in it. |
---|
1953 | sub split_line |
---|
1954 | { |
---|
1955 | unless (@_ == 1) |
---|
1956 | { |
---|
1957 | croak "$0: split_line $INCORRECT_NUMBER_OF_ARGS"; |
---|
1958 | } |
---|
1959 | |
---|
1960 | my $line = shift; |
---|
1961 | |
---|
1962 | # Strip leading whitespace. Do not strip trailing whitespace which |
---|
1963 | # may be part of quoted text that was never closed. |
---|
1964 | $line =~ s/^\s+//; |
---|
1965 | |
---|
1966 | my $line_length = length $line; |
---|
1967 | my @words = (); |
---|
1968 | my $current_word = ''; |
---|
1969 | my $in_quote = ''; |
---|
1970 | my $in_protect = ''; |
---|
1971 | my $in_space = ''; |
---|
1972 | my $i = 0; |
---|
1973 | |
---|
1974 | while ($i < $line_length) |
---|
1975 | { |
---|
1976 | my $c = substr($line, $i, 1); |
---|
1977 | ++$i; |
---|
1978 | |
---|
1979 | if ($in_protect) |
---|
1980 | { |
---|
1981 | if ($c eq $in_quote) |
---|
1982 | { |
---|
1983 | $current_word .= $c; |
---|
1984 | } |
---|
1985 | elsif ($c eq '"' or $c eq "'") |
---|
1986 | { |
---|
1987 | $current_word .= $c; |
---|
1988 | } |
---|
1989 | else |
---|
1990 | { |
---|
1991 | $current_word .= "$in_protect$c"; |
---|
1992 | } |
---|
1993 | $in_protect = ''; |
---|
1994 | } |
---|
1995 | elsif ($c eq '\\') |
---|
1996 | { |
---|
1997 | $in_protect = $c; |
---|
1998 | } |
---|
1999 | elsif ($in_quote) |
---|
2000 | { |
---|
2001 | if ($c eq $in_quote) |
---|
2002 | { |
---|
2003 | $in_quote = ''; |
---|
2004 | } |
---|
2005 | else |
---|
2006 | { |
---|
2007 | $current_word .= $c; |
---|
2008 | } |
---|
2009 | } |
---|
2010 | elsif ($c eq '"' or $c eq "'") |
---|
2011 | { |
---|
2012 | $in_quote = $c; |
---|
2013 | } |
---|
2014 | elsif ($c =~ m/^\s$/) |
---|
2015 | { |
---|
2016 | unless ($in_space) |
---|
2017 | { |
---|
2018 | push(@words, $current_word); |
---|
2019 | $current_word = ''; |
---|
2020 | } |
---|
2021 | } |
---|
2022 | else |
---|
2023 | { |
---|
2024 | $current_word .= $c; |
---|
2025 | } |
---|
2026 | |
---|
2027 | $in_space = $c =~ m/^\s$/; |
---|
2028 | } |
---|
2029 | |
---|
2030 | # Handle any leftovers. |
---|
2031 | $current_word .= $in_protect if $in_protect; |
---|
2032 | push(@words, $current_word) if length $current_word; |
---|
2033 | |
---|
2034 | @words; |
---|
2035 | } |
---|
2036 | |
---|
2037 | # This package exists just to delete the temporary directory. |
---|
2038 | package Temp::Delete; |
---|
2039 | |
---|
2040 | sub new |
---|
2041 | { |
---|
2042 | bless {}, shift; |
---|
2043 | } |
---|
2044 | |
---|
2045 | sub DESTROY |
---|
2046 | { |
---|
2047 | print "Cleaning up $temp_dir\n"; |
---|
2048 | File::Path::rmtree([$temp_dir], 0, 0); |
---|
2049 | } |
---|