source: LMDZ5/branches/LMDZ6_rc0/tools/fcm/lib/Fcm/CmUrl.pm @ 3411

Last change on this file since 3411 was 1665, checked in by Laurent Fairhead, 12 years ago

Version testing basée sur la r1628

http://lmdz.lmd.jussieu.fr/utilisateurs/distribution-du-modele/versions-intermediaires

Testing release based on r1628
File size: 32.1 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    # --------------------------------------------------------------------------
416    $return .= '|| ' . &svn_date ($log{date}) . ' || ' . $log{author} . ' || ';
417
418    my $trac_url = &get_browser_url (URL => $self->url);
419
420    # Get list of tickets from log
421    my @tickets;
422    while ($log{msg} =~ /(?:#|ticket:)(\d+)/g) {
423      push @tickets, $1;
424    }
425    @tickets = sort {$a <=> $b} @tickets;
426
427    if ($trac_url =~ m#^$wiki(?:/*|$)#) {
428      # URL is in the specified $wiki, use Trac link
429      $return .= '[' . $rev . '] ||';
430
431      for my $ticket (@tickets) {
432        $return .= ' #' . $ticket;
433      }
434
435      $return .= ' ||';
436
437    } else {
438      # URL is not in the specified $wiki, use full URL
439      my $rev_url = $trac_url;
440      $rev_url    =~ s#/browser/.*$##;
441      $rev_url   .= '/changeset/' . $rev;
442      $return    .= '[' . $rev_url . ' ' . $rev . '] ||';
443
444      my $ticket_url = $trac_url;
445      $ticket_url    =~ s#/browser/.*$#/ticket/#;
446
447      for my $ticket (@tickets) {
448        $return .= ' [' . $ticket_url . $ticket . ' ' . $ticket . ']';
449      }
450
451      $return .= ' ||';
452    }
453
454  } else {
455    # Output in plain text format
456    # --------------------------------------------------------------------------
457    my @msg  = split /\n/, $log{msg};
458    my $line = (@msg > 1 ? ' lines' : ' line');
459
460    $return .= join (
461      ' | ',
462      ('r' . $rev, $log{author}, &svn_date ($log{date}), scalar (@msg) . $line),
463    );
464    $return .= "\n\n";
465    $return .= $log{msg};
466  }
467
468  return $return;
469}
470
471# ------------------------------------------------------------------------------
472# SYNOPSIS
473#   @list = $cm_url->svnlist ([REV => $rev], [RECURSIVE => 1]);
474#
475# DESCRIPTION
476#   The method returns a list of paths as returned by "svn list". If RECURSIVE
477#   is set, "svn list" is invoked with the "-R" option.
478# ------------------------------------------------------------------------------
479
480sub svnlist {
481  my $self = shift;
482  my %args = @_;
483
484  my $recursive = exists $args{RECURSIVE} ? $args{RECURSIVE} : 0;
485  my $rev       = exists $args{REV}       ? $args{REV}       : undef;
486  my $key       = $recursive ? 'RLIST' : 'LIST';
487
488  # Find out last changed revision of the current URL
489  $rev = $self->svninfo (FLAG => 'Last Changed Rev', REV => $rev);
490  return () if not $rev;
491
492  # Get directory listing for the current URL at the last changed revision
493  if (not exists $self->{$key}{$rev}) {
494    my $rc;
495
496    my @list = map {chomp; $_} &run_command (
497      [qw/svn list -r/, $rev, ($recursive ? '-R' : ()), $self->url_peg],
498      METHOD => 'qx', ERROR => 'ignore', DEVNULL => 1, RC => \$rc,
499    );
500
501    $self->{$key}{$rev} = $rc ? undef : \@list;
502  }
503
504  return (defined ($self->{$key}{$rev}) ? @{ $self->{$key}{$rev} } : undef);
505}
506
507# ------------------------------------------------------------------------------
508# SYNOPSIS
509#   @list = $cm_url->branch_list ($rev);
510#
511# DESCRIPTION
512#   The method returns a list of branches in the current project, assuming the
513#   FCM naming convention. If $rev if specified, it returns the list of
514#   branches at $rev.
515# ------------------------------------------------------------------------------
516
517sub branch_list {
518  my ($self, $rev) = @_;
519
520  # Current URL must be a valid FCM project
521  return if not $self->project;
522
523  # Find out last changed revision of the current URL
524  $rev = $self->svninfo (FLAG => 'Revision', REV => $rev);
525  return () if not $rev;
526
527  if (not exists $self->{BRANCH_LIST}{$rev}) {
528    $self->{BRANCH_LIST}{$rev} = [];
529
530    # Get URL of the project "branches/" sub-directory
531    my $url = Fcm::CmUrl->new (URL => $self->project_url . '/branches');
532
533    # List three levels underneath "branches/"
534    # First level, i.e. dev, test, pkg, etc
535    my @list1 = map {$url->url . '/' . $_} $url->svnlist (REV => $rev);
536    @list1    = grep m#/$#, @list1;
537
538    # Second level, i.e. user name, Shared, Rel or Config
539    my @list2;
540    for (@list1) {
541      my $u    = Fcm::CmUrl->new (URL => $_);
542      my @list = $u->svnlist (REV => $rev);
543
544      push @list2, map {$u->url . $_} @list;
545    }
546
547    # Third level, branch name
548    for (@list2) {
549      my $u    = Fcm::CmUrl->new (URL => $_);
550      my @list = map {s#/*$##; $_} $u->svnlist (REV => $rev);
551
552      push @{ $self->{BRANCH_LIST}{$rev} }, map {$u->url . $_} @list;
553    }
554  }
555
556  return @{ $self->{BRANCH_LIST}{$rev} };
557}
558
559# ------------------------------------------------------------------------------
560# SYNOPSIS
561#   $self->_analyse_url ();
562#
563# DESCRIPTION
564#   The method analyses the current URL, breaking it up into the project
565#   (substring of URL up to the slash before "trunk", "branches" or "tags"),
566#   branch name ("trunk", "branches/<type>/<id>/<name>" or "tags/<name>") and
567#   the sub-directory below the top of the project sub-tree. It re-sets the
568#   corresponding interal variables.
569# ------------------------------------------------------------------------------
570
571sub _analyse_url {
572  my $self = shift;
573  my ($url, $project, $branch, $subdir, $pegrev);
574
575  # Check that URL is set
576  $url    = $self->url_peg;
577  return if not $url;
578  return if not $self->is_url;
579
580  # Extract from URL the peg revision
581  $pegrev = $1 if $url =~ s/@($rev_pattern)$//i;
582
583  if ($url =~ m#^(.*?)/+(trunk|branches|tags)(?:/+(.*))?/*$#) {
584    # URL is under the "trunk", a branch or a tag
585    $project                 = $1;
586    my ($branch_id, $remain) = ($2, $3);
587
588    $remain = '' if not defined $remain;
589
590    if ($branch_id eq 'trunk') {
591      # URL under the "trunk"
592      $branch = 'trunk';
593
594    } else {
595      # URL under a branch or a tag
596      $branch = $branch_id;
597
598      # Assume "3 sub-directories", FCM branch naming convention
599      for (1 .. 3) {
600        if ($remain =~ s#^([^/]+)(?:/+|$)##) {
601          $branch .=  '/' . $1;
602
603        } else {
604          $branch = undef;
605          last;
606        }
607      }
608    }
609
610    $subdir = $remain ? $remain : '' if $branch;
611
612  } else {
613    # URL is at some level above the "trunk", a branch or a tag
614    # Use "svn ls" to determine whether it is a project URL
615    my @list = $self->svnlist (REV => ($pegrev ? $pegrev : 'HEAD'));
616    my %lines = map {chomp $_; ($_, 1)} @list;
617
618    # A project URL should have the "trunk", "branches" and "tags" directories
619    ($project = $url) =~ s#/*$##
620      if $lines{'trunk/'} and $lines{'branches/'} and $lines{'tags/'};
621  }
622
623  $self->{PROJECT}  = $project;
624  $self->{BRANCH}   = $branch;
625  $self->{SUBDIR}   = $subdir;
626  $self->{PEGREV}   = $pegrev;
627  $self->{ANALYSED} = 1;
628
629  return;
630}
631
632# ------------------------------------------------------------------------------
633# SYNOPSIS
634#   $url = $cm_url->root ();
635#
636# DESCRIPTION
637#   The method returns the repository root of the current URL.
638# ------------------------------------------------------------------------------
639
640sub root {
641  my $self = shift;
642
643  return $self->svninfo (FLAG => 'Repository Root');
644}
645
646# ------------------------------------------------------------------------------
647# SYNOPSIS
648#   $url = $cm_url->project_url_peg ();
649#   $cm_url->project_url_peg ($url);
650#
651# DESCRIPTION
652#   The method returns the URL@PEG of the "project" part of the current URL. If
653#   an argument is specified, the URL of the "project" part and the peg
654#   revision of the current URL are re-set.
655# ------------------------------------------------------------------------------
656
657sub project_url_peg {
658  my $self = shift;
659
660  if (@_) {
661    my $url = shift;
662
663    # Re-construct URL is necessary
664    if (! $self->project_url_peg or $url ne $self->project_url_peg) {
665      my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : '';
666
667      $url .= '/' . $self->branch if $self->branch;
668      $url .= '/' . $self->subdir if $self->subdir;
669      $url .= '@' . $pegrev       if $pegrev;
670
671      $self->url_peg ($url);
672    }
673  }
674
675  $self->_analyse_url () if not $self->{ANALYSED};
676
677  return $self->{PROJECT} . ($self->pegrev ? '@' . $self->pegrev : '');
678}
679
680# ------------------------------------------------------------------------------
681# SYNOPSIS
682#   $url = $cm_url->project_url ();
683#   $cm_url->project_url ($url);
684#
685# DESCRIPTION
686#   The method returns the URL of the "project" part of the current URL. If an
687#   argument is specified, the URL of the "project" part of the current URL is
688#   re-set.
689# ------------------------------------------------------------------------------
690
691sub project_url {
692  my $self = shift;
693
694  if (@_) {
695    my $url = shift;
696    $url =~ s/@($rev_pattern)$//i;
697
698    # Re-construct URL is necessary
699    if (! $self->project_url or $url ne $self->project_url) {
700      $url .= '/' . $self->branch if $self->branch;
701      $url .= '/' . $self->subdir if $self->subdir;
702
703      $self->url ($url);
704    }
705  }
706
707  $self->_analyse_url () if not $self->{ANALYSED};
708
709  return $self->{PROJECT};
710}
711
712# ------------------------------------------------------------------------------
713# SYNOPSIS
714#   $path = $cm_url->project_path ();
715#   $cm_url->project_path ($path);
716#
717# DESCRIPTION
718#   The method returns the path of the "project" part of the current URL. If an
719#   argument is specified, the path of the "project" part of the current URL is
720#   re-set.
721# ------------------------------------------------------------------------------
722
723sub project_path {
724  my $self = shift;
725
726  # Repository root
727  my $root = $self->root;
728  $root    = substr (
729    $self->project_url,
730    0,
731    length ($self->project_url) - length ($self->project) - 1
732  ) if not $root;
733
734  if (@_) {
735    my $path = shift;
736
737    # Re-construct URL is necessary
738    if (! $self->project_path or $path ne $self->project_path) {
739      $path .= '/' . $self->branch if $self->branch;
740      $path .= '/' . $self->subdir if $self->subdir;
741
742      $self->path ($path);
743    }
744  }
745
746  $self->_analyse_url () if not $self->{ANALYSED};
747
748  return substr ($self->{PROJECT}, length ($root));
749}
750
751# ------------------------------------------------------------------------------
752# SYNOPSIS
753#   $name = $cm_url->project ();
754#   $cm_url->project ($name);
755#
756# DESCRIPTION
757#   The method returns the basename of the "project" part of the current URL.
758#   If an argument is specified, the basename of the "project" part of the
759#   current URL is re-set.
760# ------------------------------------------------------------------------------
761
762sub project {
763  my $self = shift;
764
765  if (@_) {
766    my $name = shift;
767
768    # Re-construct URL is necessary
769    if (! $self->project or $name ne $self->project) {
770      my $url = '';
771      if ($self->project) {
772        $url =  $self->project;
773        $url =~ s#/[^/]+$##;
774
775      } else {
776        $url =  $self->root;
777      }
778
779      $url .=  '/' . $name;
780      $url .=  '/' . $self->branch if $self->branch;
781      $url .=  '/' . $self->subdir if $self->subdir;
782      $url .=  '@' . $self->pegrev if $self->pegrev;
783
784      $self->url_peg ($url);
785    }
786  }
787
788  $self->_analyse_url () if not $self->{ANALYSED};
789
790  my $name = $self->{PROJECT};
791  $name =~ s#^.*/([^/]+)$#$1# if $name;
792
793  return $name;
794}
795
796# ------------------------------------------------------------------------------
797# SYNOPSIS
798#   $url = $cm_url->branch_url_peg ();
799#   $cm_url->branch_url_peg ($url);
800#
801# DESCRIPTION
802#   The method returns the URL@PEG of the "branch" part of the current URL. If
803#   an argument is specified, the URL@PEG of the "branch" part of the current
804#   URL is re-set.
805# ------------------------------------------------------------------------------
806
807sub branch_url_peg {
808  my $self = shift;
809
810  if (@_) {
811    my $url = shift;
812
813    # Re-construct URL is necessary
814    if (! $self->branch_url_peg or $url ne $self->branch_url_peg) {
815      my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : '';
816
817      $url .= '/' . $self->subdir if $self->subdir;
818      $url .= '@' . $pegrev       if $pegrev;
819
820      $self->url_peg ($url);
821    }
822  }
823
824  $self->_analyse_url () if not $self->{ANALYSED};
825
826  return $self->project_url . '/' . $self->branch .
827         ($self->pegrev ? '@' . $self->pegrev : '');
828}
829
830# ------------------------------------------------------------------------------
831# SYNOPSIS
832#   $url = $cm_url->branch_url ();
833#   $cm_url->branch_url ($url);
834#
835# DESCRIPTION
836#   The method returns the URL of the "branch" part of the current URL. If an
837#   argument is specified, the URL of the "branch" part of the current URL is
838#   re-set.
839# ------------------------------------------------------------------------------
840
841sub branch_url {
842  my $self = shift;
843
844  if (@_) {
845    my $url = shift;
846    $url =~ s/@($rev_pattern)$//i;
847
848    # Re-construct URL is necessary
849    if (! $self->branch_url or $url ne $self->branch_url) {
850      $url .= '/' . $self->subdir if $self->subdir;
851
852      $self->url ($url);
853    }
854  }
855
856  $self->_analyse_url () if not $self->{ANALYSED};
857
858  return $self->project_url . '/' . $self->branch;
859}
860
861# ------------------------------------------------------------------------------
862# SYNOPSIS
863#   $path = $cm_url->branch_path ();
864#   $cm_url->branch_path ($path);
865#
866# DESCRIPTION
867#   The method returns the path of the "branch" part of the current URL. If an
868#   argument is specified, the path of the "branch" part of the current URL is
869#   re-set.
870# ------------------------------------------------------------------------------
871
872sub branch_path {
873  my $self = shift;
874
875  if (@_) {
876    my $path = shift;
877
878    # Re-construct URL is necessary
879    if (! $self->branch_path or $path ne $self->branch_path) {
880      $path .= '/' . $self->subdir if $self->subdir;
881
882      $self->path ($path);
883    }
884  }
885
886  $self->_analyse_url () if not $self->{ANALYSED};
887
888  return $self->project_path . '/' . $self->branch;
889}
890
891# ------------------------------------------------------------------------------
892# SYNOPSIS
893#   $branch = $cm_url->branch ();
894#   $cm_url->branch ($branch);
895#
896# DESCRIPTION
897#   The method returns the "branch" part of the current URL. If an argument is
898#   specified, the "branch" part of the current URL is re-set.
899# ------------------------------------------------------------------------------
900
901sub branch {
902  my $self = shift;
903
904  if (@_) {
905    my $branch = shift;
906
907    # Re-construct URL is necessary
908    if (! $self->branch or $branch ne $self->branch) {
909      my $url = $self->project_url;
910      $url   .= '/' . $branch;
911      $url   .= '/' . $self->subdir if $self->subdir;
912
913      $self->url ($url);
914    }
915  }
916
917  $self->_analyse_url () if not $self->{ANALYSED};
918
919  return $self->{BRANCH};
920}
921
922# ------------------------------------------------------------------------------
923# SYNOPSIS
924#   $flag = $cm_url->is_trunk ();
925#
926# DESCRIPTION
927#   The method returns true if the the current URL is (a sub-tree of) the trunk.
928# ------------------------------------------------------------------------------
929
930sub is_trunk {
931  my $self = shift;
932
933  $self->_analyse_url () if not $self->{ANALYSED};
934
935  return ($self->branch and $self->branch eq 'trunk');
936}
937
938# ------------------------------------------------------------------------------
939# SYNOPSIS
940#   $flag = $cm_url->is_branch ();
941#
942# DESCRIPTION
943#   The method returns true if the the current URL is (a sub-tree of) a branch.
944# ------------------------------------------------------------------------------
945
946sub is_branch {
947  my $self = shift;
948
949  $self->_analyse_url () if not $self->{ANALYSED};
950
951  return ($self->branch and $self->branch =~ m#^branches/#);
952}
953
954# ------------------------------------------------------------------------------
955# SYNOPSIS
956#   $flag = $cm_url->is_tag ();
957#
958# DESCRIPTION
959#   The method returns true if the the current URL is (a sub-tree of) a tag.
960# ------------------------------------------------------------------------------
961
962sub is_tag {
963  my $self = shift;
964
965  $self->_analyse_url () if not $self->{ANALYSED};
966
967  return ($self->branch and $self->branch =~ m#^tags/#);
968}
969
970# ------------------------------------------------------------------------------
971# SYNOPSIS
972#   $subdir = $cm_url->subdir ();
973#   $cm_url->subdir ($subdir);
974#
975# DESCRIPTION
976#   The method returns the "subdir" part of the current URL. If an argument is
977#   specified, the "subdir" part of the current URL is re-set.
978# ------------------------------------------------------------------------------
979
980sub subdir {
981  my $self = shift;
982
983  if (@_) {
984    my $subdir = shift;
985
986    # Re-construct URL is necessary
987    if (! $self->subdir or $subdir ne $self->subdir) {
988      my $url = $self->project_url;
989      $url   .= '/' . $self->branch if $self->branch;
990      $url   .= '/' . $subdir if $subdir;
991
992      $self->url ($url);
993    }
994  }
995
996  $self->_analyse_url () if not $self->{ANALYSED};
997
998  return $self->{SUBDIR};
999}
1000
1001# ------------------------------------------------------------------------------
1002# SYNOPSIS
1003#   $url = $cm_url->url ();
1004#   $cm_url->url ($url);
1005#
1006# DESCRIPTION
1007#   The method returns the URL without the "peg revision" part. If an argument
1008#   is specified, the URL is re-set without modifying the "peg revision" part.
1009# ------------------------------------------------------------------------------
1010
1011sub url {
1012  my $self = shift;
1013
1014  if (@_) {
1015    my $url = shift;
1016    $url    =~ s/@($rev_pattern)$//i;
1017
1018    # Re-construct URL if necessary
1019    if (! $self->url or $url ne $self->url) {
1020      $self->url_peg ($url . ($self->pegrev ? '@' . $self->pegrev : ''));
1021    }
1022  }
1023
1024  $self->_analyse_url () if not $self->{ANALYSED};
1025
1026  (my $url = $self->url_peg) =~ s/@($rev_pattern)$//i;
1027
1028  return $url;
1029}
1030
1031# ------------------------------------------------------------------------------
1032# SYNOPSIS
1033#   $path = $cm_url->path ();
1034#   $cm_url->path ($path);
1035#
1036# DESCRIPTION
1037#   The method returns the "path" part of the URL (i.e. URL without the
1038#   "root" part). If an argument is specified, the "path" part of the URL is
1039#   re-set.
1040# ------------------------------------------------------------------------------
1041
1042sub path {
1043  my $self = shift;
1044
1045  # Repository root
1046  my $root = $self->root;
1047  $root    = substr (
1048    $self->project_url,
1049    0,
1050    length ($self->project_url) - length ($self->project) - 1
1051  ) if not $root;
1052
1053  if (@_) {
1054    my $path = shift;
1055    $path    =~ s/@($rev_pattern)$//i;
1056
1057    # Re-construct URL is necessary
1058    if (! $self->path or $path ne $self->path) {
1059      my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path);
1060      $self->url ($url);
1061    }
1062  }
1063
1064  $self->_analyse_url () if not $self->{ANALYSED};
1065
1066  return substr ($self->url, length ($root));
1067}
1068
1069# ------------------------------------------------------------------------------
1070# SYNOPSIS
1071#   $path = $cm_url->path_peg ();
1072#   $cm_url->path_peg ($path);
1073#
1074# DESCRIPTION
1075#   The method returns the PATH@PEG part of the URL (i.e. URL without the
1076#   "root" part). If an argument is specified, the PATH@PEG part of the URL is
1077#   re-set.
1078# ------------------------------------------------------------------------------
1079
1080sub path_peg {
1081  my $self = shift;
1082
1083  # Repository root
1084  my $root = $self->root;
1085  $root    = substr (
1086    $self->project_url,
1087    0,
1088    length ($self->project_url) - length ($self->project) - 1
1089  ) if not $root;
1090
1091  if (@_) {
1092    my $path = shift;
1093
1094    # Re-construct URL is necessary
1095    if (! $self->path_peg or $path ne $self->path_peg) {
1096      my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path);
1097      $self->url_peg ($url);
1098    }
1099  }
1100
1101  $self->_analyse_url () if not $self->{ANALYSED};
1102
1103  return substr ($self->url_peg, length ($root));
1104}
1105
1106# ------------------------------------------------------------------------------
1107# SYNOPSIS
1108#   $rev = $cm_url->pegrev ();
1109#   $cm_url->pegrev ($rev);
1110#
1111# DESCRIPTION
1112#   The method returns the "peg revision" part of the current URL. If an
1113#   argument is specified, the "peg revision" part of the current URL is
1114#   re-set.
1115# ------------------------------------------------------------------------------
1116
1117sub pegrev {
1118  my $self = shift;
1119
1120  if (@_) {
1121    my $pegrev = shift;
1122
1123    # Re-construct URL is necessary
1124    if (! $self->pegrev or $pegrev ne $self->pegrev) {
1125      $self->url_peg ($self->url . ($pegrev ? '@' . $pegrev : ''));
1126    }
1127  }
1128
1129  $self->_analyse_url () if not $self->{ANALYSED};
1130
1131  return $self->{PEGREV};
1132}
1133
1134# ------------------------------------------------------------------------------
1135
11361;
1137
1138__END__
Note: See TracBrowser for help on using the repository browser.