source: codes/icosagcm/trunk/tools/FCM/lib/Fcm/CmUrl.pm @ 10

Last change on this file since 10 was 10, checked in by ymipsl, 12 years ago

dynamico tree creation

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