source: branches/UKMO/r6232_tracer_advection/NEMOGCM/EXTERNAL/fcm/lib/Fcm/CmUrl.pm @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 3 years ago

Remove svn keywords

File size: 32.4 KB
Line 
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
15package Fcm::CmUrl;
16@ISA = qw(Fcm::Base);
17
18# Standard pragma
19use warnings;
20use strict;
21
22# Standard modules
23use HTTP::Date;
24use XML::DOM;
25
26# FCM component modules
27use Fcm::Base;
28use Fcm::Keyword;
29use Fcm::Util qw/run_command svn_date/;
30
31# Special branches
32our %owner_keywords = (Share => 'shared', Config => 'config', Rel => 'release');
33
34# Revision pattern
35my $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
48sub 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
75sub 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
99sub 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
115sub 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
133sub 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
201sub 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
385sub 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
471sub 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
508sub 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
562sub _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
631sub 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
648sub 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
682sub 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
714sub 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
753sub 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
798sub 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
832sub 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
863sub 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
892sub 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
921sub 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
941sub 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
957sub 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
973sub 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
991sub 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
1022sub 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
1053sub 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
1091sub 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
1128sub 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
11471;
1148
1149__END__
Note: See TracBrowser for help on using the repository browser.