1 | # ------------------------------------------------------------------------------ |
---|
2 | # NAME |
---|
3 | # Fcm::CmUrl |
---|
4 | # |
---|
5 | # DESCRIPTION |
---|
6 | # This class contains methods for manipulating a Subversion URL in a standard |
---|
7 | # FCM project. |
---|
8 | # |
---|
9 | # COPYRIGHT |
---|
10 | # (C) Crown copyright Met Office. All rights reserved. |
---|
11 | # For further details please refer to the file COPYRIGHT.txt |
---|
12 | # which you should have received as part of this distribution. |
---|
13 | # ------------------------------------------------------------------------------ |
---|
14 | |
---|
15 | package Fcm::CmUrl; |
---|
16 | @ISA = qw(Fcm::Base); |
---|
17 | |
---|
18 | # Standard pragma |
---|
19 | use warnings; |
---|
20 | use strict; |
---|
21 | |
---|
22 | # Standard modules |
---|
23 | use HTTP::Date; |
---|
24 | use XML::DOM; |
---|
25 | |
---|
26 | # FCM component modules |
---|
27 | use Fcm::Base; |
---|
28 | use Fcm::Keyword; |
---|
29 | use Fcm::Util qw/run_command svn_date/; |
---|
30 | |
---|
31 | # Special branches |
---|
32 | our %owner_keywords = (Share => 'shared', Config => 'config', Rel => 'release'); |
---|
33 | |
---|
34 | # Revision pattern |
---|
35 | my $rev_pattern = '\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}'; |
---|
36 | |
---|
37 | # ------------------------------------------------------------------------------ |
---|
38 | # SYNOPSIS |
---|
39 | # $cm_url = Fcm::CmUrl->new ([URL => $url,]); |
---|
40 | # |
---|
41 | # DESCRIPTION |
---|
42 | # This method constructs a new instance of the Fcm::CmUrl class. |
---|
43 | # |
---|
44 | # ARGUMENTS |
---|
45 | # URL - URL of a branch |
---|
46 | # ------------------------------------------------------------------------------ |
---|
47 | |
---|
48 | sub new { |
---|
49 | my $this = shift; |
---|
50 | my %args = @_; |
---|
51 | my $class = ref $this || $this; |
---|
52 | |
---|
53 | my $self = Fcm::Base->new (%args); |
---|
54 | |
---|
55 | $self->{URL} = (exists $args{URL} ? $args{URL} : ''); |
---|
56 | |
---|
57 | for (qw/ANALYSED BRANCH BRANCH_LIST INFO LIST LOG LOG_RANGE PEGREV RLIST |
---|
58 | PROJECT SUBDIR/) { |
---|
59 | $self->{$_} = undef; |
---|
60 | } |
---|
61 | |
---|
62 | bless $self, $class; |
---|
63 | return $self; |
---|
64 | } |
---|
65 | |
---|
66 | # ------------------------------------------------------------------------------ |
---|
67 | # SYNOPSIS |
---|
68 | # $url = $cm_url->url_peg; |
---|
69 | # $cm_url->url_peg ($url); |
---|
70 | # |
---|
71 | # DESCRIPTION |
---|
72 | # This method returns/sets the current URL@PEG. |
---|
73 | # ------------------------------------------------------------------------------ |
---|
74 | |
---|
75 | sub url_peg { |
---|
76 | my $self = shift; |
---|
77 | |
---|
78 | if (@_) { |
---|
79 | if (! $self->{URL} or $_[0] ne $self->{URL}) { |
---|
80 | # Re-set URL |
---|
81 | $self->{URL} = shift; |
---|
82 | |
---|
83 | # Re-set essential variables |
---|
84 | $self->{$_} = undef for (qw/ANALYSED RLIST LIST INFO LOG LOG_RANGE/); |
---|
85 | } |
---|
86 | } |
---|
87 | |
---|
88 | return $self->{URL}; |
---|
89 | } |
---|
90 | |
---|
91 | # ------------------------------------------------------------------------------ |
---|
92 | # SYNOPSIS |
---|
93 | # $flag = $cm_url->is_url (); |
---|
94 | # |
---|
95 | # DESCRIPTION |
---|
96 | # Returns true if current url is a valid Subversion URL. |
---|
97 | # ------------------------------------------------------------------------------ |
---|
98 | |
---|
99 | sub is_url { |
---|
100 | my $self = shift; |
---|
101 | |
---|
102 | # This should handle URL beginning with svn://, http:// and svn+ssh:// |
---|
103 | return ($self->url_peg =~ m#^[\+\w]+://#); |
---|
104 | } |
---|
105 | |
---|
106 | # ------------------------------------------------------------------------------ |
---|
107 | # SYNOPSIS |
---|
108 | # $flag = $cm_url->url_exists ([$rev]); |
---|
109 | # |
---|
110 | # DESCRIPTION |
---|
111 | # Returns true if current url exists (at operative revision $rev) in a |
---|
112 | # Subversion repository. |
---|
113 | # ------------------------------------------------------------------------------ |
---|
114 | |
---|
115 | sub url_exists { |
---|
116 | my ($self, $rev) = @_; |
---|
117 | |
---|
118 | my $exists = $self->svnlist (REV => $rev); |
---|
119 | |
---|
120 | return defined ($exists); |
---|
121 | } |
---|
122 | |
---|
123 | # ------------------------------------------------------------------------------ |
---|
124 | # SYNOPSIS |
---|
125 | # $string = $cm_url->svninfo ([FLAG => $flag], [REV => $rev]); |
---|
126 | # |
---|
127 | # DESCRIPTION |
---|
128 | # Returns the value of $flag, where $flag is a field returned by "svn info". |
---|
129 | # (If $flag is not set, default to "URL".) Otherwise returns an empty string. |
---|
130 | # If REV is specified, it will be used as the operative revision. |
---|
131 | # ------------------------------------------------------------------------------ |
---|
132 | |
---|
133 | sub svninfo { |
---|
134 | my $self = shift; |
---|
135 | my %args = @_; |
---|
136 | |
---|
137 | my $flag = exists $args{FLAG} ? $args{FLAG} : 'URL'; |
---|
138 | my $rev = exists $args{REV} ? $args{REV} : undef; |
---|
139 | |
---|
140 | $rev = ($self->pegrev ? $self->pegrev : 'HEAD') if not $rev; |
---|
141 | |
---|
142 | return if not $self->is_url; |
---|
143 | |
---|
144 | # Get "info" for the specified revision if necessary |
---|
145 | if (not exists $self->{INFO}{$rev}) { |
---|
146 | # Invoke "svn info" command |
---|
147 | my @info = &run_command ( |
---|
148 | [qw/svn info -r/, $rev, $self->url_peg], |
---|
149 | PRINT => $self->config->verbose > 2, |
---|
150 | METHOD => 'qx', |
---|
151 | DEVNULL => 1, |
---|
152 | ERROR => 'ignore', |
---|
153 | ); |
---|
154 | |
---|
155 | # Store selected information |
---|
156 | for (@info) { |
---|
157 | chomp; |
---|
158 | |
---|
159 | if (/^(.+?):\s*(.+)$/) { |
---|
160 | $self->{INFO}{$rev}{$1} = $2; |
---|
161 | } |
---|
162 | } |
---|
163 | } |
---|
164 | |
---|
165 | my $return = exists $self->{INFO}{$rev}{$flag} |
---|
166 | ? $self->{INFO}{$rev}{$flag} : undef; |
---|
167 | |
---|
168 | return $return; |
---|
169 | } |
---|
170 | |
---|
171 | # ------------------------------------------------------------------------------ |
---|
172 | # SYNOPSIS |
---|
173 | # %logs = $cm_url->svnlog ( |
---|
174 | # [REV => $rev,] |
---|
175 | # [REV => \@revs,] # reference to a 2-element array |
---|
176 | # [STOP_ON_COPY => 1,] |
---|
177 | # ); |
---|
178 | # |
---|
179 | # DESCRIPTION |
---|
180 | # Returns the logs for the current URL. If REV is a range of revisions or not |
---|
181 | # specified, return a hash where the keys are revision numbers and the values |
---|
182 | # are the entries (which are hash references). If a single REV is specified, |
---|
183 | # return the entry (a hash reference) at the specified REV. Each entry in the |
---|
184 | # returned list is a hash reference, with the following structure: |
---|
185 | # |
---|
186 | # $entry = { |
---|
187 | # author => $author, # the commit author |
---|
188 | # date => $date, # the commit date (in seconds since epoch) |
---|
189 | # msg => $msg, # the log message |
---|
190 | # paths => { # list of changed paths |
---|
191 | # $path1 => { # a changed path |
---|
192 | # copyfrom-path => $frompath, # copy-from-path |
---|
193 | # copyfrom-rev => $fromrev, # copy-from-revision |
---|
194 | # action => $action, # action status code |
---|
195 | # }, |
---|
196 | # ... => { ... }, # ... more changed paths ... |
---|
197 | # }, |
---|
198 | # } |
---|
199 | # ------------------------------------------------------------------------------ |
---|
200 | |
---|
201 | sub svnlog { |
---|
202 | my $self = shift; |
---|
203 | my %args = @_; |
---|
204 | |
---|
205 | my $stop_on_copy = exists $args{STOP_ON_COPY} ? $args{STOP_ON_COPY} : 0; |
---|
206 | my $rev_arg = exists $args{REV} ? $args{REV} : 0; |
---|
207 | |
---|
208 | my @revs; |
---|
209 | |
---|
210 | # Get revision options |
---|
211 | # ---------------------------------------------------------------------------- |
---|
212 | if ($rev_arg) { |
---|
213 | if (ref ($rev_arg)) { |
---|
214 | # Revsion option is an array, a range of revisions specified? |
---|
215 | ($revs [0], $revs [1]) = @$rev_arg; |
---|
216 | |
---|
217 | } else { |
---|
218 | # A single revision specified |
---|
219 | $revs [0] = $rev_arg; |
---|
220 | } |
---|
221 | |
---|
222 | # Expand 'HEAD' revision |
---|
223 | for my $rev (@revs) { |
---|
224 | next unless uc ($rev) eq 'HEAD'; |
---|
225 | $rev = $self->svninfo (FLAG => 'Revision', REV => 'HEAD'); |
---|
226 | } |
---|
227 | |
---|
228 | } else { |
---|
229 | # No revision option specified, get log for all revisions |
---|
230 | $revs [0] = $self->svninfo (FLAG => 'Revision'); |
---|
231 | $revs [1] = 1; |
---|
232 | } |
---|
233 | |
---|
234 | $revs [1] = $revs [0] if not $revs [1]; |
---|
235 | @revs = sort {$b <=> $a} @revs; |
---|
236 | |
---|
237 | # Check whether a "svn log" run is necessary |
---|
238 | # ---------------------------------------------------------------------------- |
---|
239 | my $need_update = ! ($revs [0] == $revs [1] and exists $self->{LOG}{$revs [0]}); |
---|
240 | my @ranges = @revs; |
---|
241 | if ($need_update and $self->{LOG_RANGE}) { |
---|
242 | my %log_range = %{ $self->{LOG_RANGE} }; |
---|
243 | |
---|
244 | if ($stop_on_copy) { |
---|
245 | $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER_SOC}; |
---|
246 | |
---|
247 | } else { |
---|
248 | $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER}; |
---|
249 | } |
---|
250 | } |
---|
251 | |
---|
252 | $need_update = 0 if $ranges [0] < $ranges [1]; |
---|
253 | |
---|
254 | if ($need_update) { |
---|
255 | # Invoke "svn log" command for all revisions of the current branch |
---|
256 | # -------------------------------------------------------------------------- |
---|
257 | my @command = ( |
---|
258 | qw/svn log --xml -v/, ($stop_on_copy ? '--stop-on-copy' : ()), |
---|
259 | '-r' . join (':', @ranges), |
---|
260 | $self->url_peg, |
---|
261 | ); |
---|
262 | |
---|
263 | my $rc; |
---|
264 | my @xml = &run_command ( |
---|
265 | \@command, |
---|
266 | PRINT => $self->config->verbose > 2, |
---|
267 | METHOD => 'qx', |
---|
268 | DEVNULL => 1, |
---|
269 | ERROR => 'ignore', |
---|
270 | RC => \$rc, |
---|
271 | ); |
---|
272 | |
---|
273 | # Parse the XML |
---|
274 | # -------------------------------------------------------------------------- |
---|
275 | if (not $rc) { |
---|
276 | my $parser = XML::DOM::Parser->new; |
---|
277 | my $doc = $parser->parse (join ('', @xml)); |
---|
278 | |
---|
279 | my $entry_list = $doc->getElementsByTagName ('logentry'); |
---|
280 | |
---|
281 | # Record the author, date, message and path change for each revision |
---|
282 | for my $i (0 .. $entry_list->getLength - 1) { |
---|
283 | # Select current entry from node list |
---|
284 | my $entry = $entry_list->item ($i); |
---|
285 | my %this = (); |
---|
286 | |
---|
287 | # Revision is an attribute of the entry node |
---|
288 | my $rev = $entry->getAttributeNode ('revision')->getValue; |
---|
289 | |
---|
290 | # Author, date and log message are children elements of the entry node |
---|
291 | for my $key (qw/author date msg/) { |
---|
292 | # Get data of each node, also convert date to seconds since epoch |
---|
293 | my $node = $entry->getElementsByTagName ($key)->item (0); |
---|
294 | my $data = ($node and $node->getFirstChild) |
---|
295 | ? $node->getFirstChild->getData : ''; |
---|
296 | $this{$key} = ($key eq 'date' ? str2time ($data) : $data); |
---|
297 | } |
---|
298 | |
---|
299 | # Path nodes are grand children elements of the entry node |
---|
300 | my $paths = $entry->getElementsByTagName ('path'); |
---|
301 | |
---|
302 | for my $p (0 .. $paths->getLength - 1) { |
---|
303 | # Select current path node from node list |
---|
304 | my $node = $paths->item ($p); |
---|
305 | |
---|
306 | # Get data from the path node |
---|
307 | my $path = $node->getFirstChild->getData; |
---|
308 | $this{paths}{$path} = {}; |
---|
309 | |
---|
310 | # Action, copyfrom-path and copyfrom-rev are attributes of path nodes |
---|
311 | for my $key (qw/action copyfrom-path copyfrom-rev/) { |
---|
312 | next unless $node->getAttributeNode ($key); # ensure attribute exists |
---|
313 | |
---|
314 | $this{paths}{$path}{$key} = $node->getAttributeNode ($key)->getValue; |
---|
315 | } |
---|
316 | } |
---|
317 | |
---|
318 | $self->{LOG}{$rev} = \%this; |
---|
319 | } |
---|
320 | } |
---|
321 | |
---|
322 | # Update the range cache |
---|
323 | # -------------------------------------------------------------------------- |
---|
324 | # Upper end of the range |
---|
325 | $self->{LOG_RANGE}{UPPER} = $ranges [0] |
---|
326 | if ! $self->{LOG_RANGE}{UPPER} or $ranges [0] > $self->{LOG_RANGE}{UPPER}; |
---|
327 | |
---|
328 | # Lower end of the range, need to take into account the stop-on-copy option |
---|
329 | if ($stop_on_copy) { |
---|
330 | # Lower end of the range with stop-on-copy option |
---|
331 | $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1] |
---|
332 | if ! $self->{LOG_RANGE}{LOWER_SOC} or |
---|
333 | $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC}; |
---|
334 | |
---|
335 | my $low = (sort {$a <=> $b} keys %{ $self->{LOG} }) [0]; |
---|
336 | $self->{LOG_RANGE}{LOWER} = $low |
---|
337 | if ! $self->{LOG_RANGE}{LOWER} or $low < $self->{LOG_RANGE}{LOWER}; |
---|
338 | |
---|
339 | } else { |
---|
340 | # Lower end of the range without the stop-on-copy option |
---|
341 | $self->{LOG_RANGE}{LOWER} = $ranges [1] |
---|
342 | if ! $self->{LOG_RANGE}{LOWER} or |
---|
343 | $ranges [1] < $self->{LOG_RANGE}{LOWER}; |
---|
344 | |
---|
345 | $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1] |
---|
346 | if ! $self->{LOG_RANGE}{LOWER_SOC} or |
---|
347 | $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC}; |
---|
348 | } |
---|
349 | } |
---|
350 | |
---|
351 | my %return = (); |
---|
352 | |
---|
353 | if (! $rev_arg or ref ($rev_arg)) { |
---|
354 | # REV is an array, return log entries if they are within range |
---|
355 | for my $rev (sort {$b <=> $a} keys %{ $self->{LOG} }) { |
---|
356 | next if $rev > $revs [0] or $revs [1] > $rev; |
---|
357 | |
---|
358 | $return{$rev} = $self->{LOG}{$rev}; |
---|
359 | |
---|
360 | if ($stop_on_copy) { |
---|
361 | last if exists $self->{LOG}{$rev}{paths}{$self->branch_path} and |
---|
362 | $self->{LOG}{$rev}{paths}{$self->branch_path}{action} eq 'A'; |
---|
363 | } |
---|
364 | } |
---|
365 | |
---|
366 | } else { |
---|
367 | # REV is a scalar, return log of the specified revision if it exists |
---|
368 | %return = %{ $self->{LOG}{$revs [0]} } if exists $self->{LOG}{$revs [0]}; |
---|
369 | } |
---|
370 | |
---|
371 | return %return; |
---|
372 | } |
---|
373 | |
---|
374 | # ------------------------------------------------------------------------------ |
---|
375 | # SYNOPSIS |
---|
376 | # $string = $cm_branch->display_svnlog ($rev, [$wiki]); |
---|
377 | # |
---|
378 | # DESCRIPTION |
---|
379 | # This method returns a string for displaying the log of the current branch |
---|
380 | # at a $rev. If $wiki is set, returns a string for displaying in a Trac wiki |
---|
381 | # table. The value of $wiki should be the Subversion URL of a FCM project |
---|
382 | # associated with the intended Trac system. |
---|
383 | # ------------------------------------------------------------------------------ |
---|
384 | |
---|
385 | sub display_svnlog { |
---|
386 | my ($self, $rev, $wiki) = @_; |
---|
387 | my $return = ''; |
---|
388 | |
---|
389 | my %log = $self->svnlog (REV => $rev); |
---|
390 | |
---|
391 | if ($wiki) { |
---|
392 | # Output in Trac wiki format |
---|
393 | # -------------------------------------------------------------------------- |
---|
394 | $return .= '|| ' . &svn_date ($log{date}) . ' || ' . $log{author} . ' || '; |
---|
395 | |
---|
396 | my $trac_url = Fcm::Keyword::get_browser_url($self->url); |
---|
397 | |
---|
398 | # Get list of tickets from log |
---|
399 | my @tickets; |
---|
400 | while ($log{msg} =~ /(?:(\w+):)?(?:#|ticket:)(\d+)/g) { |
---|
401 | push @tickets, [$1, $2]; |
---|
402 | } |
---|
403 | @tickets = sort { |
---|
404 | if ($a->[0] and $b->[0]) { |
---|
405 | $a->[0] cmp $b->[0] or $a->[1] <=> $b->[1]; |
---|
406 | |
---|
407 | } elsif ($a->[0]) { |
---|
408 | 1; |
---|
409 | |
---|
410 | } else { |
---|
411 | $a->[1] <=> $b->[1]; |
---|
412 | } |
---|
413 | } @tickets; |
---|
414 | |
---|
415 | if ($trac_url =~ m#^$wiki(?:/*|$)#) { |
---|
416 | # URL is in the specified $wiki, use Trac link |
---|
417 | $return .= '[' . $rev . '] ||'; |
---|
418 | |
---|
419 | for my $ticket (@tickets) { |
---|
420 | $return .= ' '; |
---|
421 | $return .= $ticket->[0] . ':' if $ticket->[0]; |
---|
422 | $return .= '#' . $ticket->[1]; |
---|
423 | } |
---|
424 | |
---|
425 | $return .= ' ||'; |
---|
426 | |
---|
427 | } else { |
---|
428 | # URL is not in the specified $wiki, use full URL |
---|
429 | my $rev_url = $trac_url; |
---|
430 | $rev_url =~ s{/intertrac/source:.*\z}{/intertrac/changeset:$rev}xms; |
---|
431 | $return .= '[' . $rev_url . ' ' . $rev . '] ||'; |
---|
432 | |
---|
433 | my $ticket_url = $trac_url; |
---|
434 | $ticket_url =~ s{/intertrac/source:.*\z}{/intertrac/}xms; |
---|
435 | |
---|
436 | for my $ticket (@tickets) { |
---|
437 | $return .= ' [' . $ticket_url; |
---|
438 | $return .= $ticket->[0] . ':' if $ticket->[0]; |
---|
439 | $return .= 'ticket:' . $ticket->[1] . ' ' . $ticket->[1] . ']'; |
---|
440 | } |
---|
441 | |
---|
442 | $return .= ' ||'; |
---|
443 | } |
---|
444 | |
---|
445 | } else { |
---|
446 | # Output in plain text format |
---|
447 | # -------------------------------------------------------------------------- |
---|
448 | my @msg = split /\n/, $log{msg}; |
---|
449 | my $line = (@msg > 1 ? ' lines' : ' line'); |
---|
450 | |
---|
451 | $return .= join ( |
---|
452 | ' | ', |
---|
453 | ('r' . $rev, $log{author}, &svn_date ($log{date}), scalar (@msg) . $line), |
---|
454 | ); |
---|
455 | $return .= "\n\n"; |
---|
456 | $return .= $log{msg}; |
---|
457 | } |
---|
458 | |
---|
459 | return $return; |
---|
460 | } |
---|
461 | |
---|
462 | # ------------------------------------------------------------------------------ |
---|
463 | # SYNOPSIS |
---|
464 | # @list = $cm_url->svnlist ([REV => $rev], [RECURSIVE => 1]); |
---|
465 | # |
---|
466 | # DESCRIPTION |
---|
467 | # The method returns a list of paths as returned by "svn list". If RECURSIVE |
---|
468 | # is set, "svn list" is invoked with the "-R" option. |
---|
469 | # ------------------------------------------------------------------------------ |
---|
470 | |
---|
471 | sub svnlist { |
---|
472 | my $self = shift; |
---|
473 | my %args = @_; |
---|
474 | |
---|
475 | my $recursive = exists $args{RECURSIVE} ? $args{RECURSIVE} : 0; |
---|
476 | my $rev = exists $args{REV} ? $args{REV} : undef; |
---|
477 | my $key = $recursive ? 'RLIST' : 'LIST'; |
---|
478 | |
---|
479 | # Find out last changed revision of the current URL |
---|
480 | $rev = $self->svninfo (FLAG => 'Last Changed Rev', REV => $rev); |
---|
481 | return () if not $rev; |
---|
482 | |
---|
483 | # Get directory listing for the current URL at the last changed revision |
---|
484 | if (not exists $self->{$key}{$rev}) { |
---|
485 | my $rc; |
---|
486 | |
---|
487 | my @list = map {chomp; $_} &run_command ( |
---|
488 | [qw/svn list -r/, $rev, ($recursive ? '-R' : ()), $self->url_peg], |
---|
489 | METHOD => 'qx', ERROR => 'ignore', DEVNULL => 1, RC => \$rc, |
---|
490 | ); |
---|
491 | |
---|
492 | $self->{$key}{$rev} = $rc ? undef : \@list; |
---|
493 | } |
---|
494 | |
---|
495 | return (defined ($self->{$key}{$rev}) ? @{ $self->{$key}{$rev} } : undef); |
---|
496 | } |
---|
497 | |
---|
498 | # ------------------------------------------------------------------------------ |
---|
499 | # SYNOPSIS |
---|
500 | # @list = $cm_url->branch_list ($rev); |
---|
501 | # |
---|
502 | # DESCRIPTION |
---|
503 | # The method returns a list of branches in the current project, assuming the |
---|
504 | # FCM naming convention. If $rev if specified, it returns the list of |
---|
505 | # branches at $rev. |
---|
506 | # ------------------------------------------------------------------------------ |
---|
507 | |
---|
508 | sub branch_list { |
---|
509 | my ($self, $rev) = @_; |
---|
510 | |
---|
511 | # Current URL must be a valid FCM project |
---|
512 | return if not $self->project; |
---|
513 | |
---|
514 | # Find out last changed revision of the current URL |
---|
515 | $rev = $self->svninfo (FLAG => 'Revision', REV => $rev); |
---|
516 | return () if not $rev; |
---|
517 | |
---|
518 | if (not exists $self->{BRANCH_LIST}{$rev}) { |
---|
519 | $self->{BRANCH_LIST}{$rev} = []; |
---|
520 | |
---|
521 | # Get URL of the project "branches/" sub-directory |
---|
522 | my $url = Fcm::CmUrl->new (URL => $self->project_url . '/branches'); |
---|
523 | |
---|
524 | # List three levels underneath "branches/" |
---|
525 | # First level, i.e. dev, test, pkg, etc |
---|
526 | my @list1 = map {$url->url . '/' . $_} $url->svnlist (REV => $rev); |
---|
527 | @list1 = grep m#/$#, @list1; |
---|
528 | |
---|
529 | # Second level, i.e. user name, Shared, Rel or Config |
---|
530 | my @list2; |
---|
531 | for (@list1) { |
---|
532 | my $u = Fcm::CmUrl->new (URL => $_); |
---|
533 | my @list = $u->svnlist (REV => $rev); |
---|
534 | |
---|
535 | push @list2, map {$u->url . $_} @list; |
---|
536 | } |
---|
537 | |
---|
538 | # Third level, branch name |
---|
539 | for (@list2) { |
---|
540 | my $u = Fcm::CmUrl->new (URL => $_); |
---|
541 | my @list = map {s#/*$##; $_} $u->svnlist (REV => $rev); |
---|
542 | |
---|
543 | push @{ $self->{BRANCH_LIST}{$rev} }, map {$u->url . $_} @list; |
---|
544 | } |
---|
545 | } |
---|
546 | |
---|
547 | return @{ $self->{BRANCH_LIST}{$rev} }; |
---|
548 | } |
---|
549 | |
---|
550 | # ------------------------------------------------------------------------------ |
---|
551 | # SYNOPSIS |
---|
552 | # $self->_analyse_url (); |
---|
553 | # |
---|
554 | # DESCRIPTION |
---|
555 | # The method analyses the current URL, breaking it up into the project |
---|
556 | # (substring of URL up to the slash before "trunk", "branches" or "tags"), |
---|
557 | # branch name ("trunk", "branches/<type>/<id>/<name>" or "tags/<name>") and |
---|
558 | # the sub-directory below the top of the project sub-tree. It re-sets the |
---|
559 | # corresponding interal variables. |
---|
560 | # ------------------------------------------------------------------------------ |
---|
561 | |
---|
562 | sub _analyse_url { |
---|
563 | my $self = shift; |
---|
564 | my ($url, $project, $branch, $subdir, $pegrev); |
---|
565 | |
---|
566 | # Check that URL is set |
---|
567 | $url = $self->url_peg; |
---|
568 | return if not $url; |
---|
569 | return if not $self->is_url; |
---|
570 | |
---|
571 | # Extract from URL the peg revision |
---|
572 | $pegrev = $1 if $url =~ s/@($rev_pattern)$//i; |
---|
573 | |
---|
574 | if ($url =~ m#^(.*?)/+(trunk|branches|tags)(?:/+(.*))?/*$#) { |
---|
575 | # URL is under the "trunk", a branch or a tag |
---|
576 | $project = $1; |
---|
577 | my ($branch_id, $remain) = ($2, $3); |
---|
578 | |
---|
579 | $remain = '' if not defined $remain; |
---|
580 | |
---|
581 | if ($branch_id eq 'trunk') { |
---|
582 | # URL under the "trunk" |
---|
583 | $branch = 'trunk'; |
---|
584 | |
---|
585 | } else { |
---|
586 | # URL under a branch or a tag |
---|
587 | $branch = $branch_id; |
---|
588 | |
---|
589 | # Assume "3 sub-directories", FCM branch naming convention |
---|
590 | for (1 .. 3) { |
---|
591 | if ($remain =~ s#^([^/]+)(?:/+|$)##) { |
---|
592 | $branch .= '/' . $1; |
---|
593 | |
---|
594 | } else { |
---|
595 | $branch = undef; |
---|
596 | last; |
---|
597 | } |
---|
598 | } |
---|
599 | } |
---|
600 | |
---|
601 | $subdir = $remain ? $remain : '' if $branch; |
---|
602 | |
---|
603 | } else { |
---|
604 | # URL is at some level above the "trunk", a branch or a tag |
---|
605 | # Use "svn ls" to determine whether it is a project URL |
---|
606 | my @list = $self->svnlist (REV => ($pegrev ? $pegrev : 'HEAD')); |
---|
607 | my %lines = map {chomp $_; ($_, 1)} @list; |
---|
608 | |
---|
609 | # A project URL should have the "trunk", "branches" and "tags" directories |
---|
610 | ($project = $url) =~ s#/*$## |
---|
611 | if $lines{'trunk/'} and $lines{'branches/'} and $lines{'tags/'}; |
---|
612 | } |
---|
613 | |
---|
614 | $self->{PROJECT} = $project; |
---|
615 | $self->{BRANCH} = $branch; |
---|
616 | $self->{SUBDIR} = $subdir; |
---|
617 | $self->{PEGREV} = $pegrev; |
---|
618 | $self->{ANALYSED} = 1; |
---|
619 | |
---|
620 | return; |
---|
621 | } |
---|
622 | |
---|
623 | # ------------------------------------------------------------------------------ |
---|
624 | # SYNOPSIS |
---|
625 | # $url = $cm_url->root (); |
---|
626 | # |
---|
627 | # DESCRIPTION |
---|
628 | # The method returns the repository root of the current URL. |
---|
629 | # ------------------------------------------------------------------------------ |
---|
630 | |
---|
631 | sub root { |
---|
632 | my $self = shift; |
---|
633 | |
---|
634 | return $self->svninfo (FLAG => 'Repository Root'); |
---|
635 | } |
---|
636 | |
---|
637 | # ------------------------------------------------------------------------------ |
---|
638 | # SYNOPSIS |
---|
639 | # $url = $cm_url->project_url_peg (); |
---|
640 | # $cm_url->project_url_peg ($url); |
---|
641 | # |
---|
642 | # DESCRIPTION |
---|
643 | # The method returns the URL@PEG of the "project" part of the current URL. If |
---|
644 | # an argument is specified, the URL of the "project" part and the peg |
---|
645 | # revision of the current URL are re-set. |
---|
646 | # ------------------------------------------------------------------------------ |
---|
647 | |
---|
648 | sub project_url_peg { |
---|
649 | my $self = shift; |
---|
650 | |
---|
651 | if (@_) { |
---|
652 | my $url = shift; |
---|
653 | |
---|
654 | # Re-construct URL is necessary |
---|
655 | if (! $self->project_url_peg or $url ne $self->project_url_peg) { |
---|
656 | my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : ''; |
---|
657 | |
---|
658 | $url .= '/' . $self->branch if $self->branch; |
---|
659 | $url .= '/' . $self->subdir if $self->subdir; |
---|
660 | $url .= '@' . $pegrev if $pegrev; |
---|
661 | |
---|
662 | $self->url_peg ($url); |
---|
663 | } |
---|
664 | } |
---|
665 | |
---|
666 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
667 | |
---|
668 | return $self->{PROJECT} . ($self->pegrev ? '@' . $self->pegrev : ''); |
---|
669 | } |
---|
670 | |
---|
671 | # ------------------------------------------------------------------------------ |
---|
672 | # SYNOPSIS |
---|
673 | # $url = $cm_url->project_url (); |
---|
674 | # $cm_url->project_url ($url); |
---|
675 | # |
---|
676 | # DESCRIPTION |
---|
677 | # The method returns the URL of the "project" part of the current URL. If an |
---|
678 | # argument is specified, the URL of the "project" part of the current URL is |
---|
679 | # re-set. |
---|
680 | # ------------------------------------------------------------------------------ |
---|
681 | |
---|
682 | sub project_url { |
---|
683 | my $self = shift; |
---|
684 | |
---|
685 | if (@_) { |
---|
686 | my $url = shift; |
---|
687 | $url =~ s/@($rev_pattern)$//i; |
---|
688 | |
---|
689 | # Re-construct URL is necessary |
---|
690 | if (! $self->project_url or $url ne $self->project_url) { |
---|
691 | $url .= '/' . $self->branch if $self->branch; |
---|
692 | $url .= '/' . $self->subdir if $self->subdir; |
---|
693 | |
---|
694 | $self->url ($url); |
---|
695 | } |
---|
696 | } |
---|
697 | |
---|
698 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
699 | |
---|
700 | return $self->{PROJECT}; |
---|
701 | } |
---|
702 | |
---|
703 | # ------------------------------------------------------------------------------ |
---|
704 | # SYNOPSIS |
---|
705 | # $path = $cm_url->project_path (); |
---|
706 | # $cm_url->project_path ($path); |
---|
707 | # |
---|
708 | # DESCRIPTION |
---|
709 | # The method returns the path of the "project" part of the current URL. If an |
---|
710 | # argument is specified, the path of the "project" part of the current URL is |
---|
711 | # re-set. |
---|
712 | # ------------------------------------------------------------------------------ |
---|
713 | |
---|
714 | sub project_path { |
---|
715 | my $self = shift; |
---|
716 | |
---|
717 | # Repository root |
---|
718 | my $root = $self->root; |
---|
719 | $root = substr ( |
---|
720 | $self->project_url, |
---|
721 | 0, |
---|
722 | length ($self->project_url) - length ($self->project) - 1 |
---|
723 | ) if not $root; |
---|
724 | |
---|
725 | if (@_) { |
---|
726 | my $path = shift; |
---|
727 | |
---|
728 | # Re-construct URL is necessary |
---|
729 | if (! $self->project_path or $path ne $self->project_path) { |
---|
730 | $path .= '/' . $self->branch if $self->branch; |
---|
731 | $path .= '/' . $self->subdir if $self->subdir; |
---|
732 | |
---|
733 | $self->path ($path); |
---|
734 | } |
---|
735 | } |
---|
736 | |
---|
737 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
738 | |
---|
739 | return substr ($self->{PROJECT}, length ($root)); |
---|
740 | } |
---|
741 | |
---|
742 | # ------------------------------------------------------------------------------ |
---|
743 | # SYNOPSIS |
---|
744 | # $name = $cm_url->project (); |
---|
745 | # $cm_url->project ($name); |
---|
746 | # |
---|
747 | # DESCRIPTION |
---|
748 | # The method returns the basename of the "project" part of the current URL. |
---|
749 | # If an argument is specified, the basename of the "project" part of the |
---|
750 | # current URL is re-set. |
---|
751 | # ------------------------------------------------------------------------------ |
---|
752 | |
---|
753 | sub project { |
---|
754 | my $self = shift; |
---|
755 | |
---|
756 | if (@_) { |
---|
757 | my $name = shift; |
---|
758 | |
---|
759 | # Re-construct URL is necessary |
---|
760 | if (! $self->project or $name ne $self->project) { |
---|
761 | my $url = ''; |
---|
762 | if ($self->project) { |
---|
763 | $url = $self->project; |
---|
764 | $url =~ s#/[^/]+$##; |
---|
765 | |
---|
766 | } else { |
---|
767 | $url = $self->root; |
---|
768 | } |
---|
769 | |
---|
770 | $url .= '/' . $name; |
---|
771 | $url .= '/' . $self->branch if $self->branch; |
---|
772 | $url .= '/' . $self->subdir if $self->subdir; |
---|
773 | $url .= '@' . $self->pegrev if $self->pegrev; |
---|
774 | |
---|
775 | $self->url_peg ($url); |
---|
776 | } |
---|
777 | } |
---|
778 | |
---|
779 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
780 | |
---|
781 | my $name = $self->{PROJECT}; |
---|
782 | $name =~ s#^.*/([^/]+)$#$1# if $name; |
---|
783 | |
---|
784 | return $name; |
---|
785 | } |
---|
786 | |
---|
787 | # ------------------------------------------------------------------------------ |
---|
788 | # SYNOPSIS |
---|
789 | # $url = $cm_url->branch_url_peg (); |
---|
790 | # $cm_url->branch_url_peg ($url); |
---|
791 | # |
---|
792 | # DESCRIPTION |
---|
793 | # The method returns the URL@PEG of the "branch" part of the current URL. If |
---|
794 | # an argument is specified, the URL@PEG of the "branch" part of the current |
---|
795 | # URL is re-set. |
---|
796 | # ------------------------------------------------------------------------------ |
---|
797 | |
---|
798 | sub branch_url_peg { |
---|
799 | my $self = shift; |
---|
800 | |
---|
801 | if (@_) { |
---|
802 | my $url = shift; |
---|
803 | |
---|
804 | # Re-construct URL is necessary |
---|
805 | if (! $self->branch_url_peg or $url ne $self->branch_url_peg) { |
---|
806 | my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : ''; |
---|
807 | |
---|
808 | $url .= '/' . $self->subdir if $self->subdir; |
---|
809 | $url .= '@' . $pegrev if $pegrev; |
---|
810 | |
---|
811 | $self->url_peg ($url); |
---|
812 | } |
---|
813 | } |
---|
814 | |
---|
815 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
816 | |
---|
817 | return $self->project_url . '/' . $self->branch . |
---|
818 | ($self->pegrev ? '@' . $self->pegrev : ''); |
---|
819 | } |
---|
820 | |
---|
821 | # ------------------------------------------------------------------------------ |
---|
822 | # SYNOPSIS |
---|
823 | # $url = $cm_url->branch_url (); |
---|
824 | # $cm_url->branch_url ($url); |
---|
825 | # |
---|
826 | # DESCRIPTION |
---|
827 | # The method returns the URL of the "branch" part of the current URL. If an |
---|
828 | # argument is specified, the URL of the "branch" part of the current URL is |
---|
829 | # re-set. |
---|
830 | # ------------------------------------------------------------------------------ |
---|
831 | |
---|
832 | sub branch_url { |
---|
833 | my $self = shift; |
---|
834 | |
---|
835 | if (@_) { |
---|
836 | my $url = shift; |
---|
837 | $url =~ s/@($rev_pattern)$//i; |
---|
838 | |
---|
839 | # Re-construct URL is necessary |
---|
840 | if (! $self->branch_url or $url ne $self->branch_url) { |
---|
841 | $url .= '/' . $self->subdir if $self->subdir; |
---|
842 | |
---|
843 | $self->url ($url); |
---|
844 | } |
---|
845 | } |
---|
846 | |
---|
847 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
848 | |
---|
849 | return $self->project_url . '/' . $self->branch; |
---|
850 | } |
---|
851 | |
---|
852 | # ------------------------------------------------------------------------------ |
---|
853 | # SYNOPSIS |
---|
854 | # $path = $cm_url->branch_path (); |
---|
855 | # $cm_url->branch_path ($path); |
---|
856 | # |
---|
857 | # DESCRIPTION |
---|
858 | # The method returns the path of the "branch" part of the current URL. If an |
---|
859 | # argument is specified, the path of the "branch" part of the current URL is |
---|
860 | # re-set. |
---|
861 | # ------------------------------------------------------------------------------ |
---|
862 | |
---|
863 | sub branch_path { |
---|
864 | my $self = shift; |
---|
865 | |
---|
866 | if (@_) { |
---|
867 | my $path = shift; |
---|
868 | |
---|
869 | # Re-construct URL is necessary |
---|
870 | if (! $self->branch_path or $path ne $self->branch_path) { |
---|
871 | $path .= '/' . $self->subdir if $self->subdir; |
---|
872 | |
---|
873 | $self->path ($path); |
---|
874 | } |
---|
875 | } |
---|
876 | |
---|
877 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
878 | |
---|
879 | return ($self->branch ? $self->project_path . '/' . $self->branch : undef); |
---|
880 | } |
---|
881 | |
---|
882 | # ------------------------------------------------------------------------------ |
---|
883 | # SYNOPSIS |
---|
884 | # $branch = $cm_url->branch (); |
---|
885 | # $cm_url->branch ($branch); |
---|
886 | # |
---|
887 | # DESCRIPTION |
---|
888 | # The method returns the "branch" part of the current URL. If an argument is |
---|
889 | # specified, the "branch" part of the current URL is re-set. |
---|
890 | # ------------------------------------------------------------------------------ |
---|
891 | |
---|
892 | sub branch { |
---|
893 | my $self = shift; |
---|
894 | |
---|
895 | if (@_) { |
---|
896 | my $branch = shift; |
---|
897 | |
---|
898 | # Re-construct URL is necessary |
---|
899 | if (! $self->branch or $branch ne $self->branch) { |
---|
900 | my $url = $self->project_url; |
---|
901 | $url .= '/' . $branch; |
---|
902 | $url .= '/' . $self->subdir if $self->subdir; |
---|
903 | |
---|
904 | $self->url ($url); |
---|
905 | } |
---|
906 | } |
---|
907 | |
---|
908 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
909 | |
---|
910 | return $self->{BRANCH}; |
---|
911 | } |
---|
912 | |
---|
913 | # ------------------------------------------------------------------------------ |
---|
914 | # SYNOPSIS |
---|
915 | # $string = $obj->branch_owner; |
---|
916 | # |
---|
917 | # DESCRIPTION |
---|
918 | # This method returns the owner of the branch. |
---|
919 | # ------------------------------------------------------------------------------ |
---|
920 | |
---|
921 | sub branch_owner { |
---|
922 | my $self = shift; |
---|
923 | my $return; |
---|
924 | |
---|
925 | if ($self->is_branch and $self->branch_url =~ m#/([^/]+)/[^/]+/*$#) { |
---|
926 | my $user = $1; |
---|
927 | $return = $user; |
---|
928 | } |
---|
929 | |
---|
930 | return $return; |
---|
931 | } |
---|
932 | |
---|
933 | # ------------------------------------------------------------------------------ |
---|
934 | # SYNOPSIS |
---|
935 | # $flag = $cm_url->is_trunk (); |
---|
936 | # |
---|
937 | # DESCRIPTION |
---|
938 | # The method returns true if the the current URL is (a sub-tree of) the trunk. |
---|
939 | # ------------------------------------------------------------------------------ |
---|
940 | |
---|
941 | sub is_trunk { |
---|
942 | my $self = shift; |
---|
943 | |
---|
944 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
945 | |
---|
946 | return ($self->branch and $self->branch eq 'trunk'); |
---|
947 | } |
---|
948 | |
---|
949 | # ------------------------------------------------------------------------------ |
---|
950 | # SYNOPSIS |
---|
951 | # $flag = $cm_url->is_branch (); |
---|
952 | # |
---|
953 | # DESCRIPTION |
---|
954 | # The method returns true if the the current URL is (a sub-tree of) a branch. |
---|
955 | # ------------------------------------------------------------------------------ |
---|
956 | |
---|
957 | sub is_branch { |
---|
958 | my $self = shift; |
---|
959 | |
---|
960 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
961 | |
---|
962 | return ($self->branch and $self->branch =~ m#^branches/#); |
---|
963 | } |
---|
964 | |
---|
965 | # ------------------------------------------------------------------------------ |
---|
966 | # SYNOPSIS |
---|
967 | # $flag = $cm_url->is_tag (); |
---|
968 | # |
---|
969 | # DESCRIPTION |
---|
970 | # The method returns true if the the current URL is (a sub-tree of) a tag. |
---|
971 | # ------------------------------------------------------------------------------ |
---|
972 | |
---|
973 | sub is_tag { |
---|
974 | my $self = shift; |
---|
975 | |
---|
976 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
977 | |
---|
978 | return ($self->branch and $self->branch =~ m#^tags/#); |
---|
979 | } |
---|
980 | |
---|
981 | # ------------------------------------------------------------------------------ |
---|
982 | # SYNOPSIS |
---|
983 | # $subdir = $cm_url->subdir (); |
---|
984 | # $cm_url->subdir ($subdir); |
---|
985 | # |
---|
986 | # DESCRIPTION |
---|
987 | # The method returns the "subdir" part of the current URL. If an argument is |
---|
988 | # specified, the "subdir" part of the current URL is re-set. |
---|
989 | # ------------------------------------------------------------------------------ |
---|
990 | |
---|
991 | sub subdir { |
---|
992 | my $self = shift; |
---|
993 | |
---|
994 | if (@_) { |
---|
995 | my $subdir = shift; |
---|
996 | |
---|
997 | # Re-construct URL is necessary |
---|
998 | if (! $self->subdir or $subdir ne $self->subdir) { |
---|
999 | my $url = $self->project_url; |
---|
1000 | $url .= '/' . $self->branch if $self->branch; |
---|
1001 | $url .= '/' . $subdir if $subdir; |
---|
1002 | |
---|
1003 | $self->url ($url); |
---|
1004 | } |
---|
1005 | } |
---|
1006 | |
---|
1007 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
1008 | |
---|
1009 | return $self->{SUBDIR}; |
---|
1010 | } |
---|
1011 | |
---|
1012 | # ------------------------------------------------------------------------------ |
---|
1013 | # SYNOPSIS |
---|
1014 | # $url = $cm_url->url (); |
---|
1015 | # $cm_url->url ($url); |
---|
1016 | # |
---|
1017 | # DESCRIPTION |
---|
1018 | # The method returns the URL without the "peg revision" part. If an argument |
---|
1019 | # is specified, the URL is re-set without modifying the "peg revision" part. |
---|
1020 | # ------------------------------------------------------------------------------ |
---|
1021 | |
---|
1022 | sub url { |
---|
1023 | my $self = shift; |
---|
1024 | |
---|
1025 | if (@_) { |
---|
1026 | my $url = shift; |
---|
1027 | $url =~ s/@($rev_pattern)$//i; |
---|
1028 | |
---|
1029 | # Re-construct URL if necessary |
---|
1030 | if (! $self->url or $url ne $self->url) { |
---|
1031 | $self->url_peg ($url . ($self->pegrev ? '@' . $self->pegrev : '')); |
---|
1032 | } |
---|
1033 | } |
---|
1034 | |
---|
1035 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
1036 | |
---|
1037 | (my $url = $self->url_peg) =~ s/@($rev_pattern)$//i; |
---|
1038 | |
---|
1039 | return $url; |
---|
1040 | } |
---|
1041 | |
---|
1042 | # ------------------------------------------------------------------------------ |
---|
1043 | # SYNOPSIS |
---|
1044 | # $path = $cm_url->path (); |
---|
1045 | # $cm_url->path ($path); |
---|
1046 | # |
---|
1047 | # DESCRIPTION |
---|
1048 | # The method returns the "path" part of the URL (i.e. URL without the |
---|
1049 | # "root" part). If an argument is specified, the "path" part of the URL is |
---|
1050 | # re-set. |
---|
1051 | # ------------------------------------------------------------------------------ |
---|
1052 | |
---|
1053 | sub path { |
---|
1054 | my $self = shift; |
---|
1055 | |
---|
1056 | # Repository root |
---|
1057 | my $root = $self->root; |
---|
1058 | $root = substr ( |
---|
1059 | $self->project_url, |
---|
1060 | 0, |
---|
1061 | length ($self->project_url) - length ($self->project) - 1 |
---|
1062 | ) if not $root; |
---|
1063 | |
---|
1064 | if (@_) { |
---|
1065 | my $path = shift; |
---|
1066 | $path =~ s/@($rev_pattern)$//i; |
---|
1067 | |
---|
1068 | # Re-construct URL is necessary |
---|
1069 | if (! $self->path or $path ne $self->path) { |
---|
1070 | my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path); |
---|
1071 | $self->url ($url); |
---|
1072 | } |
---|
1073 | } |
---|
1074 | |
---|
1075 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
1076 | |
---|
1077 | return substr ($self->url, length ($root)); |
---|
1078 | } |
---|
1079 | |
---|
1080 | # ------------------------------------------------------------------------------ |
---|
1081 | # SYNOPSIS |
---|
1082 | # $path = $cm_url->path_peg (); |
---|
1083 | # $cm_url->path_peg ($path); |
---|
1084 | # |
---|
1085 | # DESCRIPTION |
---|
1086 | # The method returns the PATH@PEG part of the URL (i.e. URL without the |
---|
1087 | # "root" part). If an argument is specified, the PATH@PEG part of the URL is |
---|
1088 | # re-set. |
---|
1089 | # ------------------------------------------------------------------------------ |
---|
1090 | |
---|
1091 | sub path_peg { |
---|
1092 | my $self = shift; |
---|
1093 | |
---|
1094 | # Repository root |
---|
1095 | my $root = $self->root; |
---|
1096 | $root = substr ( |
---|
1097 | $self->project_url, |
---|
1098 | 0, |
---|
1099 | length ($self->project_url) - length ($self->project) - 1 |
---|
1100 | ) if not $root; |
---|
1101 | |
---|
1102 | if (@_) { |
---|
1103 | my $path = shift; |
---|
1104 | |
---|
1105 | # Re-construct URL is necessary |
---|
1106 | if (! $self->path_peg or $path ne $self->path_peg) { |
---|
1107 | my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path); |
---|
1108 | $self->url_peg ($url); |
---|
1109 | } |
---|
1110 | } |
---|
1111 | |
---|
1112 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
1113 | |
---|
1114 | return substr ($self->url_peg, length ($root)); |
---|
1115 | } |
---|
1116 | |
---|
1117 | # ------------------------------------------------------------------------------ |
---|
1118 | # SYNOPSIS |
---|
1119 | # $rev = $cm_url->pegrev (); |
---|
1120 | # $cm_url->pegrev ($rev); |
---|
1121 | # |
---|
1122 | # DESCRIPTION |
---|
1123 | # The method returns the "peg revision" part of the current URL. If an |
---|
1124 | # argument is specified, the "peg revision" part of the current URL is |
---|
1125 | # re-set. |
---|
1126 | # ------------------------------------------------------------------------------ |
---|
1127 | |
---|
1128 | sub pegrev { |
---|
1129 | my $self = shift; |
---|
1130 | |
---|
1131 | if (@_) { |
---|
1132 | my $pegrev = shift; |
---|
1133 | |
---|
1134 | # Re-construct URL is necessary |
---|
1135 | if (! $self->pegrev or $pegrev ne $self->pegrev) { |
---|
1136 | $self->url_peg ($self->url . ($pegrev ? '@' . $pegrev : '')); |
---|
1137 | } |
---|
1138 | } |
---|
1139 | |
---|
1140 | $self->_analyse_url () if not $self->{ANALYSED}; |
---|
1141 | |
---|
1142 | return $self->{PEGREV}; |
---|
1143 | } |
---|
1144 | |
---|
1145 | # ------------------------------------------------------------------------------ |
---|
1146 | |
---|
1147 | 1; |
---|
1148 | |
---|
1149 | __END__ |
---|