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::Project;
52use strict;
53use SVK::Version;  our $VERSION = $SVK::VERSION;
54use Path::Class;
55use SVK::Logger;
56use SVK::I18N;
57use base 'Class::Accessor::Fast';
58use autouse 'SVK::Util' => qw( reformat_svn_date );
59
60__PACKAGE__->mk_accessors(
61    qw(name trunk branch_location tag_location local_root depot));
62
63=head1 NAME
64
65SVK::Project - SVK project class
66
67=head1 SYNOPSIS
68
69 See below
70
71=head1 DESCRIPTION
72
73The class represents a project within svk.
74
75=cut
76
77use List::MoreUtils 'apply';
78
79sub branches {
80    my ( $self, $local ) = @_;
81
82    my $fs              = $self->depot->repos->fs;
83    my $root            = $fs->revision_root( $fs->youngest_rev );
84    my $branch_location = $local ? $self->local_root : $self->branch_location;
85
86    return [ apply {$_->[0] =~ s{^\Q$branch_location\E/}{}}
87        @{ $self->_find_branches( $root, $branch_location ) } ];
88}
89
90sub tags {
91    my ( $self ) = @_;
92    return [] unless $self->tag_location;
93
94    my $fs              = $self->depot->repos->fs;
95    my $root            = $fs->revision_root( $fs->youngest_rev );
96    my $tag_location    = $self->tag_location;
97
98    return [ apply {$_->[0] =~ s{^\Q$tag_location\E/}{}}
99        @{ $self->_find_branches( $root, $tag_location ) } ];
100}
101
102sub _find_branches {
103    my ( $self, $root, $path ) = @_;
104    my $pool    = SVN::Pool->new_default;
105    return [] if $SVN::Node::none == $root->check_path($path);
106    my $entries = $root->dir_entries($path);
107
108    my $trunk = SVK::Path->real_new(
109        {   depot    => $self->depot,
110            revision => $root->revision_root_revision,
111            path     => $self->trunk
112        }
113    );
114
115    my @branches;
116
117    for my $entry ( sort keys %$entries ) {
118        next unless $entries->{$entry}->kind == $SVN::Node::dir;
119        my $b = $trunk->mclone( path => $path . '/' . $entry );
120        next if $b->path eq $trunk->path;
121
122        push @branches, $b->related_to($trunk)
123            ? [$b->path, $self->{verbose} ? ":\n    ".$self->lastchanged_info($b) : ""]
124            : @{ $self->_find_branches( $root, $path . '/' . $entry ) };
125    }
126    return \@branches;
127}
128
129sub lastchanged_info {
130    my ($self, $target) = @_;
131    if (defined( my $lastchanged = $target->root->node_created_rev( $target->path ))) {
132	my $date
133	    = $target->root->fs->revision_prop( $lastchanged, 'svn:date' );
134	my $author
135	    = $target->root->fs->revision_prop( $lastchanged, 'svn:author' );
136	return sprintf (
137	    "Last Changed Rev: %s (%s, by %s)",
138	    $lastchanged,
139	    reformat_svn_date( "%Y-%m-%d", $date ),
140	    $author
141	);
142    }
143}
144
145sub allprojects {
146    my ($self, $pathobj) = @_;
147
148    my $fs              = $pathobj->depot->repos->fs;
149    my $root            = $fs->revision_root( $fs->youngest_rev );
150    my @all_mirrors     = split "\n", $root->node_prop('/','svm:mirror') || '';
151    my $prop_path = '';
152    my @projects;
153
154    foreach my $m_path (@all_mirrors) {
155	if ($pathobj->path eq '/') {
156	    my $proj = $self->_create_from_prop($pathobj, $root, $m_path);
157	    push @projects, $proj if $proj;
158	}
159    }
160    return \@projects;
161}
162
163sub create_from_prop {
164    my ($self, $pathobj, $pname) = @_;
165
166    my $fs              = $pathobj->depot->repos->fs;
167    my $root            = $fs->revision_root( $fs->youngest_rev );
168    my @all_mirrors     = split "\n", $root->node_prop('/','svm:mirror') || '';
169    my $prop_path = '';
170    my $proj;
171
172    foreach my $m_path (@all_mirrors) {
173	if ($pathobj->path eq '/' and $pname) { # in non-wc path
174	    $proj = $self->_create_from_prop($pathobj, $root, $m_path, $pname);
175	    return $proj if $proj;
176	} elsif ($pathobj->_to_pclass("/local")->subsumes($pathobj->path)) {
177	    $proj = $self->_create_from_prop($pathobj, $root, $m_path, $pname);
178	    return $proj if $proj;
179	} else {
180	    if ($pathobj->path =~ m/^$m_path/) {
181		$prop_path = $m_path;
182		last;
183	    }
184	}
185    }
186    $proj = $self->_create_from_prop($pathobj, $root, $prop_path, $pname);
187    return $proj if $proj;
188    return $self->_create_from_prop($pathobj, $root, $prop_path, $pname, 1);
189}
190
191sub _project_names {
192    my ($self, $allprops, $pname) = @_;
193    my ($depotroot)     = '/';
194    return
195        map  { $_ => 1}
196	grep { (1 and !$pname) or ($_ eq $pname)  } # if specified pname, the grep it only
197	grep { $_ =~ s/^svk:project:([^:]+):.*$/$1/ }
198	grep { $allprops->{$_} =~ /$depotroot/ } sort keys %{$allprops};
199}
200
201sub _project_paths {
202    my ($self, $allprops) = @_;
203    return
204        map  { $allprops->{$_} => $_ }
205	grep { $_ =~ m/^svk:project/ } sort keys %{$allprops};
206}
207
208sub _create_from_prop {
209    my ($self, $pathobj, $root, $prop_path, $pname, $from_local) = @_;
210    my $allprops        = $root->node_proplist($from_local ? '/' : $prop_path);
211    my %projnames = $self->_project_names($allprops, $pname);
212    return unless %projnames;
213
214    # Given a lists of projects: 'rt32', 'rt34', 'rt38' in lexcialorder
215    # if the suffix of prop_path matches $project_name like /mirror/rt38 matches rt38
216    # then 'rt38' should be used to try before 'rt36', 'rt32'...
217
218    for my $project_name ( sort { $prop_path =~ m/$b$/ } keys %projnames)  {
219	$prop_path = $allprops->{'svk:project:'.$project_name.':root'}
220	    if ($allprops->{'svk:project:'.$project_name.':root'} and
221		($from_local || $prop_path eq '/'));
222	my %props =
223#	    map { $_ => '/'.$allprops->{'svk:project:'.$project_name.':'.$_} }
224	    map {
225		my $prop = $allprops->{'svk:project:'.$project_name.':'.$_};
226		$prop =~ s{/$}{} if $prop;
227		$prop =~ s{^/}{} if $prop;
228		$_ => $prop ? $prop_path.'/'.$prop : '' }
229		('path-trunk', 'path-branches', 'path-tags');
230
231	# only the current path matches one of the branches/trunk/tags, the project
232	# is returned
233	for my $key (keys %props) {
234	    next unless $props{$key};
235	    return SVK::Project->new(
236		{
237		    name            => $project_name,
238		    depot           => $pathobj->depot,
239		    trunk           => $props{'path-trunk'},
240		    branch_location => $props{'path-branches'},
241		    tag_location    => $props{'path-tags'},
242		    local_root      => "/local/${project_name}",
243		}) if $pathobj->path =~ m/^$props{$key}/ or $props{$key} =~ m/^$pathobj->{'path'}/
244		      or $pathobj->path =~ m{^/local/$project_name};
245	}
246    }
247    return undef;
248}
249
250sub create_from_path {
251    my ($self, $depot, $path, $pname) = @_;
252    my $rev = undef;
253
254    my $path_obj = SVK::Path->real_new(
255        {   depot    => $depot,
256            path     => $path
257        }
258    );
259    $path_obj->refresh_revision;
260
261    my ($project_name, $trunk_path, $branch_path, $tag_path) =
262	$self->_find_project_path($path_obj);
263
264    return undef unless $project_name;
265    return undef if $pname and $pname ne $project_name;
266    return SVK::Project->new(
267	{
268	    name            => $project_name,
269	    depot           => $path_obj->depot,
270	    trunk           => $trunk_path,
271	    branch_location => $branch_path,
272	    tag_location    => $tag_path,
273	    local_root      => "/local/${project_name}",
274	});
275}
276
277sub _check_project_path {
278    my ($self, $path_obj, $trunk_path, $branch_path, $tag_path) = @_;
279
280    my $checked_result = 1;
281    # check trunk, branch, tag, these should be metadata-ed
282    # we check if the structure of mirror is correct, otherwise go again
283    for my $_path ($trunk_path, $branch_path, $tag_path) {
284        unless ($path_obj->root->check_path($_path) == $SVN::Node::dir) {
285            if ($tag_path eq $_path) { # tags directory is optional
286                $checked_result = 2; # no tags
287            }
288            else {
289                return 0;
290            }
291        }
292    }
293    return $checked_result;
294}
295
296# this is heuristics guessing of project and should be replaced
297# eventually when we can define project meta data.
298sub _find_project_path {
299    my ($self, $path_obj) = @_;
300
301    my ($mirror_path,$project_name);
302    my ($trunk_path, $branch_path, $tag_path);
303    my $current_path = $path_obj->_to_pclass($path_obj->path);
304
305    if ($path_obj->_to_pclass("/local")->subsumes($current_path)) { # guess if in local branch
306	# should only be 1 entry
307	$current_path = ($path_obj->copy_ancestors)[0]->[0] if $path_obj->copy_ancestors;
308	$path_obj = $path_obj->copied_from if $path_obj->copied_from;
309    }
310
311    # Finding inverse layout first
312    my ($path) = $current_path =~ m{^/(.+?/(?:trunk|branches|tags)/[^/]+)};
313    if ($path) {
314        ($mirror_path, $project_name) = # always assume the last entry the projectname
315            $path =~ m{^(.*/)?(?:trunk|branches|tags)/(.+)$};
316        if ($project_name and $path_obj->root->check_path($mirror_path) == $SVN::Node::dir) {
317            ($trunk_path, $branch_path, $tag_path) =
318                map { $mirror_path.$_.'/'.$project_name } ('trunk', 'branches', 'tags');
319            my $result = $self->_check_project_path ($path_obj, $trunk_path, $branch_path, $tag_path);
320	    $tag_path = '' if $result == 2;
321            return ($project_name, $trunk_path, $branch_path, $tag_path) if $result > 0;
322        }
323        $project_name = '';
324        $path = '';
325    }
326    # not found in inverse layout, else
327    ($path) = $current_path =~ m{^(.*?)(?:/(?:trunk|branches/.*?|tags/.*?))?/?$};
328
329    while (!$project_name) {
330	($mirror_path,$project_name) = # always assume the last entry the projectname
331	    $path =~ m{^(.*/)?([\w\-_]+)$};
332	return undef unless $project_name; # can' find any project_name
333	$mirror_path ||= '';
334
335	($trunk_path, $branch_path, $tag_path) =
336	    map { $mirror_path.$project_name."/".$_ } ('trunk', 'branches', 'tags');
337        return undef unless ($path_obj->root->check_path($mirror_path.$project_name) == $SVN::Node::dir);
338	my $result = $self->_check_project_path ($path_obj, $trunk_path, $branch_path, $tag_path);
339	# if not the last entry, then the mirror_path should contains
340	# trunk/branches/tags, otherwise no need to test
341	($path) = $mirror_path =~ m{^(.+(?=/(?:trunk|branches|tags)))}
342	    unless $result != 0;
343	$tag_path = '' if $result == 2;
344	$project_name = '' unless $result;
345	return undef unless $path;
346    }
347    return ($project_name, $trunk_path, $branch_path, $tag_path);
348}
349
350sub depotpath_in_branch_or_tag {
351    my ($self, $name) = @_;
352    # return 1 for branch, 2 for tag, others => 0
353    return '/'.dir($self->depot->depotname,$self->branch_location,$name)->as_foreign('Unix')
354	if grep { $_->[0] eq $name } @{$self->branches};
355    return '/'.dir($self->depot->depotname,$self->tag_location,$name)->as_foreign('Unix')
356	if grep { $_ eq $name } @{$self->tags};
357    return ;
358}
359
360sub branch_name {
361    my ($self, $bpath, $is_local) = @_;
362    return 'trunk' if (dir($self->trunk)->subsumes($bpath));
363    my $branch_location = $is_local ? $self->local_root : $self->branch_location;
364    $bpath =~ s{^\Q$branch_location\E/}{};
365    my $pbname;
366    ($pbname) = grep { my $base = $_->[0]; $bpath =~ m#^$base(/|$)# } @{$self->branches};
367    return $pbname->[0] if $pbname;
368    return $bpath;
369}
370
371sub branch_path {
372    my ($self, $bname, $is_local) = @_;
373    my $branch_path =
374        ($is_local ?
375            $self->local_root."/$bname"
376            :
377            ($bname ne 'trunk' ?
378                $self->branch_location . "/$bname" : $self->trunk)
379        );
380    $branch_path =
381	'/'.dir($self->depot->depotname)->subdir($branch_path)->as_foreign('Unix');
382    return $branch_path;
383}
384
385sub tag_name {
386    my ($self, $bpath) = @_;
387    return 'trunk' if (dir($self->trunk)->subsumes($bpath));
388    my $tag_location = $self->tag_location;
389    $bpath =~ s{^\Q$tag_location\E/}{};
390    my $pbname;
391    ($pbname) = grep { $bpath =~ m#^$_(/|$)# } @{$self->tags};
392    return $pbname if $pbname;
393    return $bpath;
394}
395
396sub tag_path {
397    my ($self, $tname) = @_;
398    my $tag_path = ($tname ne 'trunk' ?  $self->tag_location . "/$tname" : $self->trunk);
399    $tag_path =
400	'/'.dir($self->depot->depotname)->subdir($tag_path)->as_foreign('Unix');
401    return $tag_path;
402}
403
404sub info {
405    my ($self, $target, $verbose) = @_;
406
407    $logger->info ( loc("Project name: %1\n", $self->name));
408    if ($target->isa('SVK::Path::Checkout')) {
409	my $where = "online";
410	my $bname = '';
411	if (dir($self->trunk)->subsumes($target->path)) {
412	    $bname = 'trunk';
413	} elsif (dir($self->branch_location)->subsumes($target->path)) {
414	    $bname = $self->branch_name($target->path);
415	} elsif ($self->tag_location and dir($self->tag_location)->subsumes($target->path)) {
416	    $bname = $self->tag_name($target->path);
417	} elsif ($target->_to_pclass("/local")->subsumes($target->path)) {
418	    $where = 'offline';
419	    $bname = $self->branch_name($target->path,1);
420	}
421
422	if ($where) {
423	    $logger->info ( loc("Branch: %1 (%2)\n", $bname, $where ));
424	    return unless $verbose;
425	    $logger->info ( loc("Revision: %1\n", $target->revision));
426	    $logger->info ( loc("Repository path: %1\n", $target->depotpath ));
427	    if ($where ne 'trunk') { # project trunk should not have Copied info
428		for ($target->copy_ancestors) {
429		    next if $bname eq $self->branch_name($_->[0]);
430		    $logger->info( loc("Copied From: %1@%2\n", $self->branch_name($_->[0]), $_->[1]));
431		    last;
432		}
433		$self->{xd} = $target->{xd};
434		$self->{merge} = SVK::Merge->new (%$self);
435		my $minfo = $self->{merge}->find_merge_sources ($target, 0,1);
436		for (sort { $minfo->{$b} <=> $minfo->{$a} } keys %$minfo) {
437		    $logger->info( loc("Merged From: %1@%2\n",$self->branch_name((split/:/)[1]),$minfo->{$_}));
438		    last;
439		}
440	    }
441	}
442    }
443}
444
445sub in_which_project {
446    my ($self, $pathobj) = @_;
447
448    my $fs              = $pathobj->depot->repos->fs;
449    my $root            = $fs->revision_root( $fs->youngest_rev );
450    my @all_mirrors     = split "\n", $root->node_prop('/','svm:mirror') || '';
451    my $prop_path       = '/';
452    foreach my $m_path (@all_mirrors) {
453        if ($pathobj->path =~ m/^$m_path/) {
454            $prop_path = $m_path;
455            last;
456        }
457    }
458    my $from_local      = $pathobj->_to_pclass("/local")->subsumes($pathobj->path);
459    my $allprops        = $root->node_proplist($from_local ? '/' : $prop_path);
460    my %projpaths       = $self->_project_paths($allprops);
461    for my $path (sort { $b ne $a } keys %projpaths) { # reverse sort to ensure subsume
462        next unless length($path);
463	if ($pathobj->_to_pclass($prop_path.$path)->subsumes($pathobj->path) or
464	    $pathobj->_to_pclass($pathobj->path)->subsumes($prop_path.$path)) {
465	    my ($pname) = $projpaths{$path} =~ m/^svk:project:(.*?):path/;
466	    return $pname;
467	}
468    }
469    return;
470}
4711;
472