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