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