[1989] | 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. |
---|
[2768] | 32 | my $svn = `which svn`; |
---|
[1989] | 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 | } |
---|