New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
CmUrl.pm in vendors/lib/FCM1 – NEMO

source: vendors/lib/FCM1/CmUrl.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing
File size: 18.6 KB
Line 
1# ------------------------------------------------------------------------------
2# (C) British Crown Copyright 2006-17 Met Office.
3#
4# This file is part of FCM, tools for managing and building source code.
5#
6# FCM is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# FCM is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with FCM. If not, see <http://www.gnu.org/licenses/>.
18# ------------------------------------------------------------------------------
19# NAME
20#   FCM1::CmUrl
21#
22# DESCRIPTION
23#   This class contains methods for manipulating a Subversion URL in a standard
24#   FCM project.
25#
26# ------------------------------------------------------------------------------
27
28package FCM1::CmUrl;
29use base qw{FCM1::Base};
30
31use strict;
32use warnings;
33
34use FCM::System::Exception;
35use FCM1::Keyword;
36use FCM1::Util qw/svn_date/;
37
38# Special branches
39our %owner_keywords = (Share => 'shared', Config => 'config', Rel => 'release');
40
41# Revision pattern
42my $rev_pattern = '\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}';
43
44my $E = 'FCM::System::Exception';
45
46# "svn log --xml" handlers.
47# -> element node start tag handlers
48my %SVN_LOG_ELEMENT_0_HANDLER_FOR = (
49#   tag        => handler
50    'logentry' => \&_svn_log_handle_element_0_logentry,
51    'path'     => \&_svn_log_handle_element_0_path,
52);
53# -> text node (after a start tag) handlers
54my %SVN_LOG_TEXT_HANDLER_FOR = (
55#   tag    => handler
56    'date' => \&_svn_log_handle_text_date,
57    'path' => \&_svn_log_handle_text_path,
58);
59
60# Set the SVN utility provided by FCM::System::CM.
61our $SVN;
62sub set_svn_util {
63    $SVN = shift();
64}
65
66# ------------------------------------------------------------------------------
67# SYNOPSIS
68#   $cm_url = FCM1::CmUrl->new ([URL => $url,]);
69#
70# DESCRIPTION
71#   This method constructs a new instance of the FCM1::CmUrl class.
72#
73# ARGUMENTS
74#   URL - URL of a branch
75# ------------------------------------------------------------------------------
76
77sub new {
78  my $this  = shift;
79  my %args  = @_;
80  my $class = ref $this || $this;
81
82  my $self = FCM1::Base->new (%args);
83
84  $self->{URL} = (exists $args{URL} ? $args{URL} : '');
85
86  for (qw/LAYOUT BRANCH_LIST INFO LIST LOG LOG_RANGE RLIST/) {
87    $self->{$_} = undef;
88  }
89
90  bless $self, $class;
91  return $self;
92}
93
94# ------------------------------------------------------------------------------
95# SYNOPSIS
96#   $url = $cm_url->url_peg;
97#   $cm_url->url_peg ($url);
98#
99# DESCRIPTION
100#   This method returns/sets the current URL@PEG.
101# ------------------------------------------------------------------------------
102
103sub url_peg {
104  my $self = shift;
105
106  if (@_) {
107    if (! $self->{URL} or $_[0] ne $self->{URL}) {
108      # Re-set URL
109      $self->{URL} = shift;
110
111      # Re-set essential variables
112      $self->{$_}  = undef for (qw/LAYOUT RLIST LIST INFO LOG LOG_RANGE/);
113    }
114  }
115
116  return $self->{URL};
117}
118
119# ------------------------------------------------------------------------------
120# SYNOPSIS
121#   $flag = $cm_url->is_url ();
122#
123# DESCRIPTION
124#   Returns true if current url is a valid Subversion URL.
125# ------------------------------------------------------------------------------
126
127sub is_url {
128  my $self = shift;
129
130  # This should handle URL beginning with svn://, http:// and svn+ssh://
131  return ($self->url_peg =~ qr{^[\w\+\-]+://}msx);
132}
133
134# ------------------------------------------------------------------------------
135# SYNOPSIS
136#   $flag = $cm_url->url_exists ([$rev]);
137#
138# DESCRIPTION
139#   Returns true if current url exists (at operative revision $rev) in a
140#   Subversion repository.
141# ------------------------------------------------------------------------------
142
143sub url_exists {
144  my ($self, $rev) = @_;
145
146  my $url = eval {$self->svninfo(FLAG => 'url', REV => $rev)};
147  if ($@) {
148    $@ = undef;
149  }
150
151  defined($url);
152}
153
154# ------------------------------------------------------------------------------
155# SYNOPSIS
156#   $string = $cm_url->svninfo([FLAG => $flag], [REV => $rev]);
157#
158# DESCRIPTION
159#   Returns the value of $flag, where $flag is a field returned by "svn info
160#   --xml". The original hierarchy below the entry element is delimited by a
161#   colon in the name. (If $flag is not set, default to "url".) If REV is
162#   specified, it will be used as the operative revision.
163# ------------------------------------------------------------------------------
164
165sub svninfo {
166  my ($self, %args) = @_;
167  if (!$self->is_url()) {
168    return;
169  }
170  my $flag = exists($args{FLAG}) ? $args{FLAG} : 'url';
171  my $rev  = exists($args{REV})  ? $args{REV}  : undef;
172  $rev ||= ($self->pegrev ? $self->pegrev : 'HEAD');
173  # Get "info" for the specified revision if necessary
174  if (!exists($self->{INFO}{$rev})) {
175    $self->{INFO}{$rev}
176      = $SVN->get_info({'revision' => $rev}, $self->url_peg())->[0];
177  }
178  exists($self->{INFO}{$rev}{$flag}) ? $self->{INFO}{$rev}{$flag} : undef;
179}
180
181# ------------------------------------------------------------------------------
182# SYNOPSIS
183#   %logs = $cm_url->svnlog (
184#     [REV          => $rev,]
185#     [REV          => \@revs,] # reference to a 2-element array
186#     [STOP_ON_COPY => 1,]
187#   );
188#
189# DESCRIPTION
190#   Returns the logs for the current URL. If REV is a range of revisions or not
191#   specified, return a hash where the keys are revision numbers and the values
192#   are the entries (which are hash references). If a single REV is specified,
193#   return the entry (a hash reference) at the specified REV. Each entry in the
194#   returned list is a hash reference, with the following structure:
195#
196#   $entry = {
197#     author => $author,              # the commit author
198#     date   => $date,                # the commit date (in seconds since epoch)
199#     msg    => $msg,                 # the log message
200#     paths  => {                     # list of changed paths
201#       $path1  => {                  # a changed path
202#         copyfrom-path => $frompath, # copy-from-path
203#         copyfrom-rev  => $fromrev,  # copy-from-revision
204#         action        => $action,   # action status code
205#       },
206#       ...     => { ... },           # ... more changed paths ...
207#     },
208#   }
209# ------------------------------------------------------------------------------
210
211sub svnlog {
212  my $self = shift;
213  my %args = @_;
214
215  my $stop_on_copy  = exists $args{STOP_ON_COPY} ? $args{STOP_ON_COPY} : undef;
216  my $rev_arg       = exists $args{REV}          ? $args{REV}          : 0;
217
218  my @revs;
219
220  # Get revision options
221  # ----------------------------------------------------------------------------
222  if ($rev_arg) {
223    if (ref ($rev_arg)) {
224      # Revision option is an array, a range of revisions specified?
225      ($revs [0], $revs [1]) = @$rev_arg;
226
227    } else {
228      # A single revision specified
229      $revs [0] = $rev_arg;
230    }
231
232    # Expand 'HEAD' revision
233    for my $rev (@revs) {
234      next unless uc ($rev) eq 'HEAD';
235      $rev = $self->svninfo(FLAG => 'revision', REV => 'HEAD');
236    }
237
238  } else {
239    # No revision option specified, get log for all revisions
240    $revs [0] = $self->svninfo(FLAG => 'revision');
241    $revs [1] = 1;
242  }
243
244  $revs [1] = $revs [0] if not $revs [1];
245  @revs     = sort {$b <=> $a} @revs;
246
247  # Check whether a "svn log" run is necessary
248  # ----------------------------------------------------------------------------
249  my $need_update = !($revs[0] == $revs[1] && exists($self->{LOG}{$revs [0]}));
250  my @ranges = @revs;
251  if ($need_update && $self->{LOG_RANGE}) {
252    my %log_range = %{$self->{LOG_RANGE}};
253    $log_range{LOWER_SOC} ||= 0;
254    $log_range{LOWER} ||= 0;
255
256    if ($stop_on_copy && $ranges[1] >= $log_range{LOWER_SOC}) {
257      if ($ranges[1] >= $log_range{LOWER_SOC}) {
258        $ranges[1] = $log_range{UPPER};
259      }
260    }
261    else {
262      if ($ranges[1] >= $log_range{LOWER}) {
263        $ranges[1] = $log_range{UPPER};
264      }
265    }
266  }
267
268  $need_update = 0 if $ranges[0] < $ranges[1];
269
270  if ($need_update) {
271    my @entries = @{$SVN->get_log(
272      {'revision' => join(':', @ranges), 'stop-on-copy' => $stop_on_copy},
273      $self->url_peg(),
274    )};
275    for my $entry (@entries) {
276      $self->{LOG}{$entry->{revision}} = $entry;
277      $entry->{paths} = {map {($_->{path} => $_)} @{$entry->{paths}}};
278    }
279
280    # Update the range cache
281    # --------------------------------------------------------------------------
282    # Upper end of the range
283    $self->{LOG_RANGE}{UPPER} = $ranges [0]
284      if ! $self->{LOG_RANGE}{UPPER} or $ranges [0] > $self->{LOG_RANGE}{UPPER};
285
286    # Lower end of the range, need to take into account the stop-on-copy option
287    if ($stop_on_copy) {
288      # Lower end of the range with stop-on-copy option
289      $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1]
290        if ! $self->{LOG_RANGE}{LOWER_SOC} or
291           $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC};
292
293      my $low = (sort {$a <=> $b} keys %{ $self->{LOG} }) [0];
294      $self->{LOG_RANGE}{LOWER} = $low
295        if ! $self->{LOG_RANGE}{LOWER} or $low < $self->{LOG_RANGE}{LOWER};
296
297    } else {
298      # Lower end of the range without the stop-on-copy option
299      $self->{LOG_RANGE}{LOWER} = $ranges [1]
300        if ! $self->{LOG_RANGE}{LOWER} or
301           $ranges [1] < $self->{LOG_RANGE}{LOWER};
302
303      $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1]
304        if ! $self->{LOG_RANGE}{LOWER_SOC} or
305           $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC};
306    }
307  }
308
309  my %return = ();
310
311  if (! $rev_arg or ref ($rev_arg)) {
312    # REV is an array, return log entries if they are within range
313    for my $rev (sort {$b <=> $a} keys %{ $self->{LOG} }) {
314      next if $rev > $revs [0] or $revs [1] > $rev;
315
316      $return{$rev} = $self->{LOG}{$rev};
317
318      if ($stop_on_copy) {
319        last if exists $self->{LOG}{$rev}{paths}{$self->branch_path} and
320           $self->{LOG}{$rev}{paths}{$self->branch_path}{action} eq 'A';
321      }
322    }
323
324  } else {
325    # REV is a scalar, return log of the specified revision if it exists
326    %return = %{ $self->{LOG}{$revs [0]} } if exists $self->{LOG}{$revs [0]};
327  }
328
329  return %return;
330}
331
332# ------------------------------------------------------------------------------
333# SYNOPSIS
334#   $string = $cm_branch->display_svnlog ($rev, [$wiki]);
335#
336# DESCRIPTION
337#   This method returns a string for displaying the log of the current branch
338#   at a $rev. If $wiki is set, returns a string for displaying in a Trac wiki
339#   table.  The value of $wiki should be the Subversion URL of a FCM project
340#   associated with the intended Trac system.
341# ------------------------------------------------------------------------------
342
343sub display_svnlog {
344  my ($self, $rev, $wiki) = @_;
345  my $return = '';
346
347  my %log = $self->svnlog (REV => $rev);
348
349  if ($wiki) {
350    # Output in Trac wiki format
351    # --------------------------------------------------------------------------
352    $return .= '|| ' . &svn_date ($log{date}) . ' || ' . $log{author} . ' || ';
353
354    my $trac_url = FCM1::Keyword::get_browser_url($self->url);
355
356    # Get list of tickets from log
357    my @tickets;
358    while ($log{msg} =~ /(?:(\w+):)?(?:#|ticket:)(\d+)/g) {
359      push @tickets, [$1, $2];
360    }
361    @tickets = sort {
362      if ($a->[0] and $b->[0]) {
363        $a->[0] cmp $b->[0] or $a->[1] <=> $b->[1];
364
365      } elsif ($a->[0]) {
366        1;
367
368      } else {
369        $a->[1] <=> $b->[1];
370      }
371    } @tickets;
372
373    if ($trac_url =~ qr{^$wiki(?:/*|$)}msx) {
374      # URL is in the specified $wiki, use Trac link
375      $return .= '[' . $rev . '] ||';
376
377      for my $ticket (@tickets) {
378        $return .= ' ';
379        $return .= $ticket->[0] . ':' if $ticket->[0];
380        $return .= '#' . $ticket->[1];
381      }
382
383      $return .= ' ||';
384
385    } else {
386      # URL is not in the specified $wiki, use full URL
387      my $rev_url = $trac_url;
388      $rev_url    =~ s{/intertrac/source:.*\z}{/intertrac/changeset:$rev}xms;
389      $return    .= '[' . $rev_url . ' ' . $rev . '] ||';
390
391      my $ticket_url = $trac_url;
392      $ticket_url    =~ s{/intertrac/source:.*\z}{/intertrac/}xms;
393
394      for my $ticket (@tickets) {
395        $return .= ' [' . $ticket_url;
396        $return .= $ticket->[0] . ':' if $ticket->[0];
397        $return .= 'ticket:' . $ticket->[1] . ' ' . $ticket->[1] . ']';
398      }
399
400      $return .= ' ||';
401    }
402
403  } else {
404    # Output in plain text format
405    # --------------------------------------------------------------------------
406    my @msg  = split /\n/, $log{msg};
407    my $line = (@msg > 1 ? ' lines' : ' line');
408
409    $return .= join (
410      ' | ',
411      ('r' . $rev, $log{author}, &svn_date ($log{date}), scalar (@msg) . $line),
412    );
413    $return .= "\n\n";
414    $return .= $log{msg};
415  }
416
417  return $return;
418}
419
420# ------------------------------------------------------------------------------
421# SYNOPSIS
422#   @list = $cm_url->branch_list ($rev);
423#
424# DESCRIPTION
425#   The method returns a list of branches in the current project, assuming the
426#   FCM naming convention. If $rev if specified, it returns the list of
427#   branches at $rev.
428# ------------------------------------------------------------------------------
429
430sub branch_list {
431  my ($self, $rev) = @_;
432  if (!defined($self->project())) {
433    return;
434  }
435  $rev = $self->svninfo(FLAG => 'revision', REV => $rev);
436  if (!exists($self->{BRANCH_LIST}{$rev})) {
437    my %layout_config = %{$self->layout()->get_config()};
438    my $url0 = $self->project_url();
439    my @d1_filters = ();
440    if ($layout_config{'dir-branch'}) {
441      $url0 .= '/' . $layout_config{'dir-branch'};
442    }
443    else {
444      for my $key (qw{trunk tag}) {
445        if ($layout_config{"dir-$key"}) {
446          push(@d1_filters, $layout_config{"dir-$key"});
447        }
448      }
449    }
450    $self->{BRANCH_LIST}{$rev} = [$SVN->get_list(
451      $url0 . '@' . $self->pegrev(),
452      sub {
453        my ($this_url, $this_name, $is_dir, $depth) = @_;
454        if ($depth == 1 && @d1_filters && grep {$this_name eq $_} @d1_filters) {
455          return (0, 0);
456        }
457        my $can_return = $depth >= $layout_config{'depth-branch'};
458        ($can_return, ($is_dir && !$can_return));
459      },
460    )];
461  }
462  @{$self->{BRANCH_LIST}{$rev}};
463}
464
465# ------------------------------------------------------------------------------
466# SYNOPSIS
467#   $layout = $self->layout();
468#
469# DESCRIPTION
470#   Wrap FCM::System::CM::SVN->get_layout($url).
471# ------------------------------------------------------------------------------
472
473sub layout {
474  my ($self) = @_;
475  if (defined($self->{LAYOUT})) {
476    return $self->{LAYOUT};
477  }
478  my $url = $self->url_peg();
479  my $layout = $SVN->get_layout($url);
480  $self->{URL} = $layout->get_url();
481  $self->{LAYOUT} = $layout;
482
483  $layout;
484}
485
486# ------------------------------------------------------------------------------
487# SYNOPSIS
488#   $url = $cm_url->url();
489#   $url = $cm_url->pegrev();
490#   $url = $cm_url->root();
491#   $url = $cm_url->path();
492#   $url = $cm_url->path_peg();
493#
494# DESCRIPTION
495#   Return the relevant part of the current URL. The url method returns the URL
496#   without the peg revision. The pegrev method returns the peg revision. The
497#   root method returns the repository root. The path method returns the path in
498#   URL under root. The path_peg method returns the path in URL with a peg
499#   revision.
500# ------------------------------------------------------------------------------
501
502sub url {
503  my $layout = $_[0]->layout();
504  $layout->get_root() . $layout->get_path();
505}
506
507sub pegrev {
508  $_[0]->layout()->get_peg_rev();
509}
510
511sub root {
512  $_[0]->layout()->get_root();
513}
514
515sub path {
516  $_[0]->layout()->get_path();
517}
518
519sub path_peg {
520  my $layout = $_[0]->layout();
521  $layout->get_path() . '@' . $layout->get_peg_rev();
522}
523
524# ------------------------------------------------------------------------------
525# SYNOPSIS
526#   $url = $cm_url->project_url_peg();
527#   $url = $cm_url->project_url();
528#   $url = $cm_url->project_path();
529#   $url = $cm_url->project();
530#   $url = $cm_url->branch_url();
531#   $url = $cm_url->branch_url_peg();
532#   $url = $cm_url->branch_path();
533#   $url = $cm_url->branch();
534#   $url = $cm_url->subdir();
535#
536# DESCRIPTION
537#   Return the relevant part of the current URL. The "project_*" methods return
538#   the "project" part. The "branch_*" methods return the "branch" part.
539#   The "*_url_peg" methods return the URL@PEG, and the "*_url" methods return
540#   the URL without the peg revision. The "*_path" methods return the path in
541#   the URL under the root.
542# ------------------------------------------------------------------------------
543
544sub project_url_peg {
545  my $layout = $_[0]->layout();
546  if (!defined($layout->get_project())) {
547    return;
548  }
549  my $path = $layout->get_project() ? '/' . $layout->get_project() : q{};
550  $layout->get_root() . $path . '@' . $layout->get_peg_rev();
551}
552
553sub project_url {
554  my $layout = $_[0]->layout();
555  if (!defined($layout->get_project())) {
556    return;
557  }
558  my $path = $layout->get_project() ? '/' . $layout->get_project() : q{};
559  $layout->get_root() . $path;
560}
561
562sub project_path {
563  my $layout = $_[0]->layout();
564  if (!defined($layout->get_project())) {
565    return;
566  }
567  '/' . $layout->get_project();
568}
569
570sub project {
571  $_[0]->layout()->get_project();
572}
573
574sub branch_url_peg {
575  my $layout = $_[0]->layout();
576  if (!$layout->get_branch()) {
577    return;
578  }
579  $_[0]->project_url() . '/' . $layout->get_branch()
580    . '@' . $layout->get_peg_rev();
581}
582
583sub branch_url {
584  my $layout = $_[0]->layout();
585  if (!$layout->get_branch()) {
586    return;
587  }
588  $_[0]->project_url() . '/' . $layout->get_branch();
589}
590
591sub branch_path {
592  my $layout = $_[0]->layout();
593  if (!$layout->get_branch()) {
594    return;
595  }
596  ($_[0]->project() ? '/' . $_[0]->project() : q{}) . '/' . $layout->get_branch();
597}
598
599sub branch {
600  $_[0]->layout()->get_branch();
601}
602
603sub subdir {
604  $_[0]->layout()->get_sub_tree();
605}
606
607# ------------------------------------------------------------------------------
608# SYNOPSIS
609#   $string = $obj->branch_owner();
610#
611# DESCRIPTION
612#   This method returns the owner of the branch (based on the default layout).
613# ------------------------------------------------------------------------------
614
615sub branch_owner {
616  $_[0]->layout()->get_branch_owner();
617}
618
619# ------------------------------------------------------------------------------
620# SYNOPSIS
621#   $flag = $cm_url->is_trunk();
622#   $flag = $cm_url->is_branch();
623#   $flag = $cm_url->is_tag();
624#
625# DESCRIPTION
626#   Return true if the branch of current URL belongs to a given category (i.e.
627#   trunk, branch or tag).
628# ------------------------------------------------------------------------------
629
630sub is_trunk {
631  $_[0]->layout()->is_trunk();
632}
633
634sub is_branch {
635  $_[0]->layout()->is_branch();
636}
637
638sub is_tag {
639  $_[0]->layout()->is_tag();
640}
641
642# ------------------------------------------------------------------------------
643
6441;
645__END__
Note: See TracBrowser for help on using the repository browser.