1# BEGIN BPS TAGGED BLOCK {{{ 2# COPYRIGHT: 3# 4# This software is Copyright (c) 2003-2008 Best Practical Solutions, LLC 5# <clkao@bestpractical.com> 6# 7# (Except where explicitly superseded by other copyright notices) 8# 9# 10# LICENSE: 11# 12# 13# This program is free software; you can redistribute it and/or 14# modify it under the terms of either: 15# 16# a) Version 2 of the GNU General Public License. You should have 17# received a copy of the GNU General Public License along with this 18# program. If not, write to the Free Software Foundation, Inc., 51 19# Franklin Street, Fifth Floor, Boston, MA 02110-1301 or visit 20# their web page on the internet at 21# http://www.gnu.org/copyleft/gpl.html. 22# 23# b) Version 1 of Perl's "Artistic License". You should have received 24# a copy of the Artistic License with this package, in the file 25# named "ARTISTIC". The license is also available at 26# http://opensource.org/licenses/artistic-license.php. 27# 28# This work is distributed in the hope that it will be useful, but 29# WITHOUT ANY WARRANTY; without even the implied warranty of 30# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 31# General Public License for more details. 32# 33# CONTRIBUTION SUBMISSION POLICY: 34# 35# (The following paragraph is not intended to limit the rights granted 36# to you to modify and distribute this software under the terms of the 37# GNU General Public License and is only of importance to you if you 38# choose to contribute your changes and enhancements to the community 39# by submitting them to Best Practical Solutions, LLC.) 40# 41# By intentionally submitting any modifications, corrections or 42# derivatives to this work, or any other work intended for use with SVK, 43# to Best Practical Solutions, LLC, you confirm that you are the 44# copyright holder for those contributions and you grant Best Practical 45# Solutions, LLC a nonexclusive, worldwide, irrevocable, royalty-free, 46# perpetual, license to use, copy, create derivative works based on 47# those contributions, and sublicense and distribute those contributions 48# and any derivatives thereof. 49# 50# END BPS TAGGED BLOCK }}} 51package SVK::Util; 52use strict; 53require Exporter; 54our @ISA = qw(Exporter); 55our @EXPORT_OK = qw( 56 IS_WIN32 DEFAULT_EDITOR TEXT_MODE HAS_SYMLINK HAS_SVN_MIRROR $EOL $SEP 57 58 get_prompt get_buffer_from_editor edit_file 59 60 get_encoding get_encoder from_native to_native 61 62 find_svm_source traverse_history 63 64 read_file write_file slurp_fh md5_fh bsd_glob mimetype mimetype_is_text 65 is_binary_file 66 67 abs_path abs2rel catdir catfile catpath devnull dirname get_anchor 68 move_path make_path splitpath splitdir tmpdir tmpfile get_depot_anchor 69 catdepot abs_path_noexist 70 71 is_symlink is_executable is_uri can_run is_path_inside is_depotpath 72 73 uri_escape uri_unescape 74 75 str2time time2str reformat_svn_date 76 77 find_dotsvk 78); 79use SVK::Version; our $VERSION = $SVK::VERSION; 80 81 82use Config (); 83use SVK::Logger; 84use SVK::I18N; 85use SVN::Core; 86use autouse 'Encode' => qw(resolve_alias($) decode encode); 87use File::Glob qw(bsd_glob); 88use autouse 'File::Basename' => qw(dirname); 89use autouse 'File::Spec::Functions' => 90 qw(catdir catpath splitpath splitdir tmpdir); 91use List::Util; 92 93 94=head1 NAME 95 96SVK::Util - Utility functions for SVK classes 97 98=head1 SYNOPSIS 99 100 use SVK::Util qw( func1 func2 func3 ) 101 102=head1 DESCRIPTION 103 104This is yet another abstraction function set for portable file, buffer and 105IO handling, tailored to SVK's specific needs. 106 107No symbols are exported by default; the user module needs to specify the 108list of functions to import. 109 110 111=head1 CONSTANTS 112 113=head2 Constant Functions 114 115=head3 IS_WIN32 116 117Boolean flag to indicate whether this system is running Microsoft Windows. 118 119=head3 DEFAULT_EDITOR 120 121The default program to invoke for editing buffers: C<notepad.exe> on Win32, 122C<vi> otherwise. 123 124=head3 TEXT_MODE 125 126The I/O layer for text files: C<:crlf> on Win32, empty otherwise. 127 128=head3 HAS_SYMLINK 129 130Boolean flag to indicate whether this system supports C<symlink()>. 131 132=head3 HAS_SVN_MIRROR 133 134Boolean flag to indicate whether we can successfully load L<SVN::Mirror>. 135 136=head2 Constant Scalars 137 138=head3 $SEP 139 140Native path separator: platform: C<\> on dosish platforms, C</> otherwise. 141 142=head3 $EOL 143 144End of line marker: C<\015\012> on Win32, C<\012> otherwise. 145 146=cut 147 148use constant IS_WIN32 => ($^O eq 'MSWin32'); 149use constant TEXT_MODE => IS_WIN32 ? ':crlf' : ''; 150use constant DEFAULT_EDITOR => IS_WIN32 ? 'notepad.exe' : 'vi'; 151use constant HAS_SYMLINK => $Config::Config{d_symlink}; 152 153sub HAS_SVN_MIRROR () { 154 no warnings 'redefine'; 155 local $@; 156 my $has_svn_mirror = $ENV{SVKNOSVM} ? 0 : eval { require SVN::Mirror; 1 }; 157 *HAS_SVN_MIRROR = $has_svn_mirror ? sub () { 1 } : sub () { 0 }; 158 return $has_svn_mirror; 159} 160 161our $SEP = catdir(''); 162our $EOL = IS_WIN32 ? "\015\012" : "\012"; 163 164=head1 FUNCTIONS 165 166=head2 User Interactivity 167 168=head3 get_prompt ($prompt, $pattern) 169 170Repeatedly prompt the user for a line of answer, until it matches 171the regular expression pattern. Returns the chomped answer line. 172 173=cut 174 175sub get_prompt { { 176 my ($prompt, $pattern) = @_; 177 178 return '' if ($ENV{'SVKBATCHMODE'}); 179 180 local $| = 1; 181 print $prompt; 182 183 local *IN; 184 local *SAVED = *STDIN; 185 local *STDIN = *STDIN; 186 187 my $formfeed = ""; 188 if (!-t STDIN and -r '/dev/tty' and open IN, '<', '/dev/tty') { 189 *STDIN = *IN; 190 $formfeed = "\r"; 191 } 192 193 require Term::ReadKey; 194 Term::ReadKey::ReadMode(IS_WIN32 ? 'normal' : 'raw'); 195 my $out = (IS_WIN32 ? sub { 1 } : sub { print @_ }); 196 197 my $erase; 198 if (!IS_WIN32 && -t) { 199 my %keys = Term::ReadKey::GetControlChars(); 200 $erase = $keys{ERASE}; 201 } 202 my $answer = ''; 203 while (defined(my $key = Term::ReadKey::ReadKey(0))) { 204 if ($key =~ /[\012\015]/) { 205 $out->("\n") if $key eq $formfeed; 206 $out->($key); last; 207 } 208 elsif ($key eq "\cC") { 209 Term::ReadKey::ReadMode('restore'); 210 *STDIN = *SAVED; 211 Term::ReadKey::ReadMode('restore'); 212 my $msg = loc("Interrupted.\n"); 213 $msg =~ s{\n\z}{$formfeed\n}; 214 die $msg; 215 } 216 elsif (defined $erase and $key eq $erase) { 217 next unless length $answer; 218 $out->("\cH \cH"); 219 chop $answer; next; 220 } 221 elsif ($key eq "\cH") { 222 next unless length $answer; 223 $out->("$key $key"); 224 chop $answer; next; 225 } 226 elsif ($key eq "\cW") { 227 my $len = (length $answer) or next; 228 $out->("\cH" x $len, " " x $len, "\cH" x $len); 229 $answer = ''; next; 230 } 231 elsif (ord $key < 32) { 232 # control character -- ignore it! 233 next; 234 } 235 $out->($key); 236 $answer .= $key; 237 } 238 239 if (defined $pattern) { 240 $answer =~ $pattern or redo; 241 } 242 243 Term::ReadKey::ReadMode('restore'); 244 return $answer; 245} } 246 247=head3 edit_file ($file_name) 248 249Launch editor to edit a file. 250 251=cut 252 253sub edit_file { 254 my ($file) = @_; 255 my $editor = defined($ENV{SVN_EDITOR}) ? $ENV{SVN_EDITOR} 256 : defined($ENV{EDITOR}) ? $ENV{EDITOR} 257 : DEFAULT_EDITOR; # fall back to something 258 my @editor = split (/ /, $editor); 259 260 if ( IS_WIN32 ) { 261 my $o; 262 my $e = shift @editor; 263 $e =~ s/^"//; 264 while ( !defined($o = can_run ($e)) ) { 265 die loc ("Can not find the editor: %1\n", $e) unless @editor; 266 $e .= " ".shift @editor; 267 $e =~ s/"$//; 268 } 269 unshift @editor, $o; 270 } 271 272 $logger->info(loc("Waiting for editor...")); 273 274 # XXX: check $? 275 system {$editor[0]} (@editor, $file) and die loc("Aborted: %1\n", $!); 276} 277 278=head3 get_buffer_from_editor ($what, $sep, $content, $filename, $anchor, $targets_ref) 279 280XXX Undocumented 281 282=cut 283 284sub get_buffer_from_editor { 285 my ( $what, $sep, $content, $file, $anchor, $targets_ref ) = @_; 286 my $fh; 287 if ( defined $content ) { 288 ( $fh, $file ) = tmpfile( $file, TEXT => 1, UNLINK => 0 ); 289 print $fh $content; 290 close $fh; 291 } else { 292 open $fh, $file or die $!; 293 local $/; 294 $content = <$fh>; 295 close $fh; 296 } 297 298 my $time = time; 299 300 while (!$ENV{'SVKBATCHMODE'} && 1) { 301 open my $fh, '<', $file or die $!; 302 my $md5 = md5_fh($fh); 303 close $fh; 304 305 edit_file($file); 306 307 open $fh, '<', $file or die $!; 308 last if ( $md5 ne md5_fh($fh) ); 309 close $fh; 310 311 my $ans = get_prompt( 312 loc( "%1 not modified: a)bort, e)dit, c)ommit?", ucfirst($what) ), 313 qr/^[aec]/, 314 ); 315 last if $ans =~ /^c/; 316 317 # XXX: save the file somewhere 318 unlink($file), die loc("Aborted.\n") if $ans =~ /^a/; 319 } 320 321 open $fh, $file or die $!; 322 local $/; 323 my @ret = defined $sep ? split( /\n\Q$sep\E\n/, <$fh>, 2 ) : (<$fh>); 324 close $fh; 325 unlink $file; 326 327 die loc("Cannot find separator; aborted.\n") 328 if defined($sep) 329 and !defined( $ret[1] ); 330 331 return $ret[0] unless wantarray; 332 333 # Compare targets in commit message 334 my $old_targets = ( split( /\n\Q$sep\E\n/, $content, 2 ) )[1]; 335 $old_targets =~ s/^\?.*//mg; # remove unversioned files 336 337 my @new_targets 338 = map { 339 s/^\s+//; # proponly change will have leading spacs 340 [ split( /[\s\+]+/, $_, 2 ) ] 341 } 342 grep { 343 !/^\?/m 344 } # remove unversioned fils 345 grep {/\S/} 346 split( /\n+/, $ret[1] ); 347 348 if ( $old_targets ne $ret[1] ) { 349 350 # Assign new targets 351 @$targets_ref = map abs2rel( $_->[1], $anchor, undef, '/' ), 352 @new_targets; 353 } 354 return ( $ret[0], \@new_targets ); 355} 356 357=head3 get_encoding 358 359Get the current encoding from locale 360 361=cut 362 363sub get_encoding { 364 return 'utf8' if $^O eq 'darwin'; 365 local $@; 366 return (resolve_alias (eval { 367 require Locale::Maketext::Lexicon; 368 local $Locale::Maketext::Lexicon::Opts{encoding} = 'locale'; 369 Locale::Maketext::Lexicon::encoding(); 370 } || eval { 371 require 'encoding.pm'; 372 defined &encoding::_get_locale_encoding() or die; 373 return encoding::_get_locale_encoding(); 374 }) or 'utf8'); 375} 376 377=head3 get_encoder ([$encoding]) 378 379=cut 380 381sub get_encoder { 382 my $enc = shift || get_encoding; 383 return Encode::find_encoding ($enc); 384} 385 386=head3 from_native ($octets, $what, [$encoding]) 387 388=cut 389 390sub from_native { 391 my $enc = ref $_[2] ? $_[2] : get_encoder ($_[2]); 392 my $buf = eval { $enc->decode ($_[0], 1) }; 393 die loc ("Can't decode %1 as %2.\n", $_[1], $enc->name) if $@; 394 $_[0] = $buf; 395 Encode::_utf8_off ($_[0]); 396 return; 397} 398 399=head3 to_native ($octets, $what, [$encoding]) 400 401=cut 402 403sub to_native { 404 my $enc = ref $_[2] ? $_[2] : get_encoder ($_[2]); 405 Encode::_utf8_on ($_[0]); 406 my $buf = eval { $enc->encode ($_[0], 1) }; 407 die loc ("Can't encode %1 as %2.\n", $_[1], $enc->name) if $@; 408 $_[0] = $buf; 409 return; 410} 411 412sub find_svm_source { # DEPRECATED: use SVK::Path->universal, only used in SVK::Command now. 413 my ($repos, $path, $rev) = @_; 414 my $t = SVK::Path->real_new({ depot => SVK::Depot->new({repos => $repos}), 415 path => $path, revision => $rev }); 416 $t->refresh_revision unless $rev; 417 my $u = $t->universal; 418 return map { $u->$_ } qw(uuid path rev); 419} 420 421=head2 File Content Manipulation 422 423=head3 read_file ($filename) 424 425Read from a file and returns its content as a single scalar. 426 427=cut 428 429sub read_file { 430 local $/; 431 open my $fh, "< $_[0]" or die $!; 432 return <$fh>; 433} 434 435=head3 write_file ($filename, $content) 436 437Write out content to a file, overwriting existing content if present. 438 439=cut 440 441sub write_file { 442 return print $_[1] if ($_[0] eq '-'); 443 open my $fh, '>', $_[0] or die $!; 444 print $fh $_[1]; 445} 446 447=head3 slurp_fh ($input_fh, $output_fh) 448 449Read all data from the input filehandle and write them to the 450output filehandle. The input may also be a scalar, or reference 451to a scalar. 452 453=cut 454 455sub slurp_fh { 456 my $from = shift; 457 my $to = shift; 458 459 local $/ = \16384; 460 461 if (!ref($from)) { 462 print $to $from; 463 } 464 elsif (ref($from) eq 'SCALAR') { 465 print $to $$from; 466 } 467 else { 468 while (<$from>) { 469 print $to $_; 470 } 471 } 472} 473 474=head3 md5_fh ($input_fh) 475 476Calculate MD5 checksum for data in the input filehandle. 477 478=cut 479 480{ 481 no warnings 'once'; 482 push @EXPORT_OK, qw( md5 ); # deprecated compatibility API 483 *md5 = *md5_fh; 484} 485 486sub md5_fh { 487 require Digest::MD5; 488 my $fh = shift; 489 my $ctx = Digest::MD5->new; 490 $ctx->addfile($fh); 491 492 return $ctx->hexdigest; 493} 494 495=head3 mimetype ($file) 496 497Return the MIME type for the file, or C<undef> if the MIME database 498is missing on the system. 499 500=cut 501 502{ my $mm; # C<state $mm>, yuck 503 504sub mimetype { 505 my ($filename) = @_; 506 507 # find an implementation module if necessary 508 $mm ||= do { 509 my $module = $ENV{SVKMIME} || 'Internal'; 510 $module =~ s/:://; 511 $module = "SVK::MimeDetect::$module"; 512 eval "require $module"; 513 die $@ if $@; 514 $module->new(); 515 }; 516 517 return $mm->checktype_filename($filename); 518} 519 520} 521 522=head3 mimetype_is_text ($mimetype) 523 524Return whether a MIME type string looks like a text file. 525 526=cut 527 528 529sub mimetype_is_text { 530 my $type = shift; 531 scalar $type =~ m{^(?:text/.* 532 |application/x-(?:perl 533 |python 534 |ruby 535 |php 536 |java 537 |[kcz]?sh 538 |awk 539 |shellscript) 540 |image/x-x(?:bit|pix)map)$}x; 541} 542 543=head3 is_binary_file ($filename OR $filehandle) 544 545Returns true if the given file or filehandle contains binary data. Otherwise, 546returns false. 547 548=cut 549 550sub is_binary_file { 551 my ($file) = @_; 552 553 # let Perl do the hard work 554 return 1 if -f $file && !-T _; # !-T handles empty files correctly 555 return; 556} 557 558=head2 Path and Filename Handling 559 560=head3 abspath ($path) 561 562Return paths with components in symlink resolved, but keep the final 563path even if it's symlink. Returns C<undef> if the base directory 564does not exist. 565 566=cut 567 568sub abs_path { 569 my $path = shift; 570 571 if (!IS_WIN32) { 572 require Cwd; 573 return Cwd::abs_path ($path) unless -l $path; 574 my (undef, $dir, $pathname) = splitpath ($path); 575 return catpath (undef, Cwd::abs_path ($dir), $pathname); 576 } 577 578 # Win32 - Complex handling to get the correct base case 579 $path = '.' if !length $path; 580 $path = ucfirst(Win32::GetFullPathName($path)); 581 return undef unless -d dirname($path); 582 583 my ($base, $remainder) = ($path, ''); 584 while (length($base) > 1) { 585 my $new_base = Win32::GetLongPathName($base); 586 return $new_base.$remainder if defined $new_base; 587 588 $new_base = dirname($base); 589 $remainder = substr($base, length($new_base)) . $remainder; 590 $base = $new_base; 591 } 592 593 return undef; 594} 595 596=head3 abs_path_noexist ($path) 597 598Return paths with components in symlink resolved, but keep the final 599path even if it's symlink. Unlike abs_path(), returns a valid value 600even if the base directory doesn't exist. 601 602=cut 603 604sub abs_path_noexist { 605 my $path = shift; 606 607 my $rest = ''; 608 until (abs_path ($path)) { 609 return $rest unless length $path; 610 my $new_path = dirname($path); 611 $rest = substr($path, length($new_path)) . $rest; 612 $path = $new_path; 613 } 614 615 return abs_path ($path) . $rest; 616} 617 618=head3 abs2rel ($pathname, $old_basedir, $new_basedir, $sep) 619 620Replace the base directory in the native pathname to another base directory 621and return the result. 622 623If the pathname is not under C<$old_basedir>, it is returned unmodified. 624 625If C<$new_basedir> is an empty string, removes the old base directory but 626keeps the leading slash. If C<$new_basedir> is C<undef>, also removes 627the leading slash. 628 629By default, the return value of this function will use C<$SEP> as its 630path separator. Setting C<$sep> to C</> will turn native path separators 631into C</> instead. 632 633=cut 634 635sub abs2rel { 636 my ($pathname, $old_basedir, $new_basedir, $sep) = @_; 637 638 my $rel = File::Spec::Functions::abs2rel($pathname, $old_basedir); 639 640 if ($rel =~ /(?:\A|\Q$SEP\E)\.\.(?:\Q$SEP\E|\z)/o) { 641 $rel = $pathname; 642 } 643 elsif (defined $new_basedir) { 644 $rel = catdir($new_basedir, $rel); 645 } 646 647 # resemble file::spec pre-3.13 behaviour, return empty string. 648 return '' if $rel eq '.'; 649 650 $rel =~ s/\Q$SEP/$sep/go if $sep and $SEP ne $sep; 651 return $rel; 652} 653 654=head3 catdir (@directories) 655 656Concatenate directory names to form a complete path; also removes the 657trailing slash from the resulting string, unless it is the root directory. 658 659=head3 catfile (@directories, $pathname) 660 661Concatenate one or more directory names and a filename to form a complete 662path, ending with a filename. If C<$pathname> contains directories, they 663will be splitted off to the end of C<@directories>. 664 665=cut 666 667sub catfile { 668 my $pathname = pop; 669 return File::Spec::Functions::catfile ( 670 (grep {defined and length} @_), splitdir($pathname) 671 ) 672} 673 674=head3 catpath ($volume, $directory, $filename) 675 676XXX Undocumented - See File::Spec 677 678=head3 devnull () 679 680Return a file name suitable for reading, and guaranteed to be empty. 681 682=cut 683 684my $devnull; 685sub devnull () { 686 IS_WIN32 ? ($devnull ||= tmpfile('', UNLINK => 1)) 687 : File::Spec::Functions::devnull(); 688} 689 690=head3 get_anchor ($need_target, @paths) 691 692Returns the (anchor, target) pairs for native path @paths. Discard 693the targets being returned unless $need_target. 694 695=cut 696 697sub get_anchor { 698 my $need_target = shift; 699 map { 700 my ($volume, $anchor, $target) = splitpath ($_); 701 chop $anchor if length ($anchor) > 1; 702 ($volume.$anchor, $need_target ? ($target) : ()) 703 } @_; 704} 705 706=head3 get_depot_anchor ($need_target, @paths) 707 708Returns the (anchor, target) pairs for depotpaths @paths. Discard the 709targets being returned unless $need_target. 710 711=cut 712 713sub get_depot_anchor { 714 my $need_target = shift; 715 map { 716 my (undef, $anchor, $target) = File::Spec::Unix->splitpath ($_); 717 chop $anchor if length ($anchor) > 1; 718 ($anchor, $need_target ? ($target) : ()) 719 } @_; 720} 721 722=head3 catdepot ($depot_name, @paths) 723 724=cut 725 726sub catdepot { 727 return File::Spec::Unix->catdir('/', @_); 728} 729 730=head3 make_path ($path) 731 732Create a directory, and intermediate directories as required. 733 734=cut 735 736sub make_path { 737 my $path = shift; 738 739 return undef if !defined($path) or -d $path; 740 741 require File::Path; 742 my @ret = eval { File::Path::mkpath([$path]) }; 743 if ($@) { 744 $@ =~ s/ at .*//; 745 die $@; 746 } 747 return @ret; 748} 749 750=head3 splitpath ($path) 751 752Splits a path in to volume, directory, and filename portions. On systems 753with no concept of volume, returns an empty string for volume. 754 755=head3 splitdir ($path) 756 757The opposite of C<catdir()>; return a list of path components. 758 759=head3 tmpdir () 760 761Return the name of the first writable directory from a list of possible 762temporary directories. 763 764=head3 tmpfile (TEXT => $is_textmode, %args) 765 766In scalar context, return the filehandle of a temporary file. 767In list context, return the filehandle and the filename. 768 769If C<$is_textmode> is true, the returned file handle is marked with 770C<TEXT_MODE>. 771 772See L<File::Temp> for valid keys of C<%args>. 773 774=cut 775 776sub tmpfile { 777 my ($temp, %args) = @_; 778 my $dir = tmpdir; 779 my $text = delete $args{TEXT}; 780 $temp = "svk-${temp}XXXXX"; 781 782 require File::Temp; 783 return File::Temp::mktemp ("$dir/$temp") if exists $args{OPEN} && $args{OPEN} == 0; 784 my $tmp = File::Temp->new ( TEMPLATE => $temp, 785 DIR => $dir, 786 SUFFIX => '.tmp', 787 %args 788 ); 789 binmode($tmp, TEXT_MODE) if $text; 790 return wantarray ? ($tmp, $tmp->filename) : $tmp; 791} 792 793=head3 is_symlink ($filename) 794 795Return whether a file is a symbolic link, as determined by C<-l>. 796If C<$filename> is not specified, return C<-l _> instead. 797 798=cut 799 800sub is_symlink { 801 HAS_SYMLINK ? @_ ? (-l $_[0]) : (-l _) : 0; 802} 803 804=head3 is_executable ($filename) 805 806Return whether a file is likely to be an executable file. 807Unlike C<is_symlink()>, the C<$filename> argument is not optional. 808 809=cut 810 811sub is_executable { 812 require ExtUtils::MakeMaker; 813 defined($_[0]) and length($_[0]) and MM->maybe_command($_[0]); 814} 815 816=head3 can_run ($filename) 817 818Check if we can run some command. 819 820=cut 821 822sub can_run { 823 my ($_cmd, @path) = @_; 824 825 return $_cmd if (-x $_cmd or $_cmd = is_executable($_cmd)); 826 827 for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), @path, '.') { 828 my $abs = catfile($dir, $_[0]); 829 next if -d $abs; 830 return $abs if (-x $abs or $abs = is_executable($abs)); 831 } 832 833 return; 834} 835 836=head3 is_uri ($string) 837 838Check if a string is a valid URI. 839 840=cut 841 842sub is_uri { 843 ($_[0] =~ /^[A-Za-z][-+.A-Za-z0-9]+:/) 844} 845 846=head3 move_path ($source, $target) 847 848Move a path to another place, creating intermediate directories in the target 849path if neccessary. If move failed, tell the user to move it manually. 850 851=cut 852 853sub move_path { 854 my ($source, $target) = @_; 855 856 if (-d $source and (!-d $target or rmdir($target))) { 857 require File::Copy; 858 make_path (dirname($target)); 859 File::Copy::move ($source => $target) and return; 860 } 861 862 $logger->error(loc( 863 "Cannot rename %1 to %2; please move it manually.", 864 catfile($source), catfile($target), 865 )); 866} 867 868=head3 traverse_history (root => $fs_root, path => $path, 869 cross => $cross, callback => $cb($path, $revision)) 870 871Traverse the history of $path in $fs_root backwards until the first 872copy, unless $cross is true. We do cross renames regardless of the 873value of $cross being non-zero, but not -1. We invoke $cb for each 874$path, $revision we encounter. If cb returns a nonzero value we stop 875traversing as well. 876 877=cut 878 879sub traverse_history { 880 my %args = @_; 881 882 my $old_pool = SVN::Pool->new; 883 my $new_pool = SVN::Pool->new; 884 my $spool = SVN::Pool->new_default; 885 886 my ($root, $path) = @args{qw/root path/}; 887 # If the root is txn root, get a similar one. 888 # XXX: We actually want to move this to SVK::Path::, and 889 # svk::checkout should respect copies on checkout 890 if ($root->can('txn') && $root->txn) { 891 ($root, $path) = $root->get_revision_root 892 ($path, $root->txn->base_revision ); 893 } 894 895 my $hist = $root->node_history ($path, $old_pool); 896 my $rv; 897 my $revision; 898 899 while (1) { 900 my $ohist = $hist; 901 $hist = $hist->prev(max(0, $args{cross} || 0), $new_pool); 902 if (!$hist) { 903 last if $args{cross}; 904 last unless $hist = $ohist->prev((1), $new_pool); 905 # We are not supposed to cross copies, ($path,$revision) 906 # refers to a node in $ohist that is a copy and that has a 907 # prev if we ask svn to traverse copies. 908 # Let's find out if the copy was actually a rename instead 909 # of a copy. 910 my $root = $root->fs->revision_root($revision, $spool); 911 my $frompath; 912 my $fromrev = -1; 913 # We know that $path was a real copy and it that it has a 914 # prev, so find the node from which it was copied. 915 do { 916 ($fromrev, $frompath) = $root->copied_from($path, $spool); 917 } until ($fromrev >= 0 || !($path =~ s{/[^/]*$}{})); 918 die "Assertion failed: $path in $revision isn't a copy." 919 if $fromrev < 0; 920 # Ok, $path in $root was a copy of ($frompath,$fromrev). 921 # If $frompath was deleted in $root then the copy was really 922 # a rename. 923 my $entry = $root->paths_changed($spool)->{$frompath}; 924 last unless $entry && 925 $entry->change_kind == $SVN::Fs::PathChange::delete; 926 927 # XXX Do we need to worry about a parent of $frompath having 928 # been deleted instead? If so the 2 lines below might work as 929 # an alternative, to the previous 3 lines. However this also 930 # treats a delete followed by a copy of an older revision in 931 # two separate commits as a rename, which technically it's not. 932 #last unless $root->check_path($frompath, $spool) == 933 # $SVN::Node::none; 934 } 935 ($path, $revision) = $hist->location ($new_pool); 936 $old_pool->clear; 937 $rv = $args{callback}->($path, $revision); 938 last if !$rv; 939 $spool->clear; 940 ($old_pool, $new_pool) = ($new_pool, $old_pool); 941 } 942 943 return $rv; 944} 945 946sub reformat_svn_date { 947 my ($format, $svn_date) = @_; 948 return time2str($format, str2time($svn_date)); 949} 950 951sub str2time { 952 require Time::Local; 953 my ($year, $month, $day, $hh, $mm, $ss) = split /[-T:]/, $_[0]; 954 $year -= 1900; 955 $month--; 956 chop($ss); # remove the 'Z' 957 my $zone = 0; # UTC 958 959 my @lt = localtime(time); 960 961 my $frac = $ss - int($ss); 962 $ss = int $ss; 963 964 for ( $year, $month, $day, $hh, $mm, $ss ) { 965 return undef unless defined($_) 966 } 967 return undef 968 unless ( $month <= 11 969 && $day >= 1 970 && $day <= 31 971 && $hh <= 23 972 && $mm <= 59 973 && $ss <= 59 ); 974 975 my $result; 976 977 $result = eval { 978 local $SIG{__DIE__} = sub { }; # Ick! 979 Time::Local::timegm( $ss, $mm, $hh, $day, $month, $year ); 980 }; 981 return undef 982 if !defined $result 983 or $result == -1 984 && join( "", $ss, $mm, $hh, $day, $month, $year ) ne "595923311169"; 985 986 return $result + $frac; 987} 988 989sub time2str { 990 my ($format, $time) = @_; 991 if (IS_WIN32) { 992 require Date::Format; 993 goto \&Date::Format::time2str; 994 } 995 996 require POSIX; 997 return POSIX::strftime($format, localtime($time) ); 998} 999 1000 1001sub find_dotsvk { 1002 require Cwd; 1003 require Path::Class; 1004 1005 my $p = Path::Class::Dir->new( Cwd::cwd() ); 1006 1007 my $prev = "not $p"; 1008 my $found = q{}; 1009 while ( $p && $p ne $prev && -r $p ) { 1010 $prev = $p; 1011 my $svk = $p->subdir('.svk'); 1012 return $svk if -e $svk && -e $svk->file('floating'); 1013 $p = $p->parent(); 1014 } 1015 1016 return 1017} 1018 1019=head3 is_path_inside($path, $parent) 1020 1021Returns true if unix path C<$path> is inside C<$parent>. 1022If they are the same, return true as well. 1023 1024=cut 1025 1026sub is_path_inside { 1027 my ($path, $parent) = @_; 1028 return 1 if $path eq $parent; 1029 return substr ($path, 0, length ($parent)+1) eq "$parent/"; 1030} 1031 1032=head3 uri_escape($uri) 1033 1034Returns escaped URI. 1035 1036=cut 1037 1038sub uri_escape { 1039 my ($uri) = @_; 1040 $uri =~ s/([^0-9A-Za-z@%+\-\/:_.!~*'()])/sprintf("%%%02X", ord($1))/eg; 1041 return $uri; 1042} 1043 1044=head3 uri_unescape($uri) 1045 1046Unescape escaped URI and return it. 1047 1048=cut 1049 1050sub uri_unescape { 1051 my ($uri) = @_; 1052 $uri =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 1053 return $uri; 1054} 1055 1056=head3 is_depotpath($path) 1057 1058Check if a string is a valid depotpath. 1059 1060=cut 1061 1062sub is_depotpath { 1063 ($_[0] =~ m|^/([^/]*)(/.*?)/?$|) 1064} 1065 10661; 1067 1068__END__ 1069 1070