123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149 |
- package Fcm::CmUrl;
- @ISA = qw(Fcm::Base);
- use warnings;
- use strict;
- use HTTP::Date;
- use XML::DOM;
- use Fcm::Base;
- use Fcm::Keyword;
- use Fcm::Util qw/run_command svn_date/;
- our %owner_keywords = (Share => 'shared', Config => 'config', Rel => 'release');
- my $rev_pattern = '\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}';
- sub new {
- my $this = shift;
- my %args = @_;
- my $class = ref $this || $this;
- my $self = Fcm::Base->new (%args);
- $self->{URL} = (exists $args{URL} ? $args{URL} : '');
- for (qw/ANALYSED BRANCH BRANCH_LIST INFO LIST LOG LOG_RANGE PEGREV RLIST
- PROJECT SUBDIR/) {
- $self->{$_} = undef;
- }
- bless $self, $class;
- return $self;
- }
- sub url_peg {
- my $self = shift;
- if (@_) {
- if (! $self->{URL} or $_[0] ne $self->{URL}) {
-
- $self->{URL} = shift;
-
- $self->{$_} = undef for (qw/ANALYSED RLIST LIST INFO LOG LOG_RANGE/);
- }
- }
- return $self->{URL};
- }
- sub is_url {
- my $self = shift;
-
- return ($self->url_peg =~ m
- }
- sub url_exists {
- my ($self, $rev) = @_;
- my $exists = $self->svnlist (REV => $rev);
- return defined ($exists);
- }
- sub svninfo {
- my $self = shift;
- my %args = @_;
- my $flag = exists $args{FLAG} ? $args{FLAG} : 'URL';
- my $rev = exists $args{REV} ? $args{REV} : undef;
- $rev = ($self->pegrev ? $self->pegrev : 'HEAD') if not $rev;
- return if not $self->is_url;
-
- if (not exists $self->{INFO}{$rev}) {
-
- my @info = &run_command (
- [qw/svn info -r/, $rev, $self->url_peg],
- PRINT => $self->config->verbose > 2,
- METHOD => 'qx',
- DEVNULL => 1,
- ERROR => 'ignore',
- );
-
- for (@info) {
- chomp;
- if (/^(.+?):\s*(.+)$/) {
- $self->{INFO}{$rev}{$1} = $2;
- }
- }
- }
- my $return = exists $self->{INFO}{$rev}{$flag}
- ? $self->{INFO}{$rev}{$flag} : undef;
- return $return;
- }
- sub svnlog {
- my $self = shift;
- my %args = @_;
- my $stop_on_copy = exists $args{STOP_ON_COPY} ? $args{STOP_ON_COPY} : 0;
- my $rev_arg = exists $args{REV} ? $args{REV} : 0;
- my @revs;
-
-
- if ($rev_arg) {
- if (ref ($rev_arg)) {
-
- ($revs [0], $revs [1]) = @$rev_arg;
- } else {
-
- $revs [0] = $rev_arg;
- }
-
- for my $rev (@revs) {
- next unless uc ($rev) eq 'HEAD';
- $rev = $self->svninfo (FLAG => 'Revision', REV => 'HEAD');
- }
- } else {
-
- $revs [0] = $self->svninfo (FLAG => 'Revision');
- $revs [1] = 1;
- }
- $revs [1] = $revs [0] if not $revs [1];
- @revs = sort {$b <=> $a} @revs;
-
-
- my $need_update = ! ($revs [0] == $revs [1] and exists $self->{LOG}{$revs [0]});
- my @ranges = @revs;
- if ($need_update and $self->{LOG_RANGE}) {
- my %log_range = %{ $self->{LOG_RANGE} };
- if ($stop_on_copy) {
- $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER_SOC};
- } else {
- $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER};
- }
- }
- $need_update = 0 if $ranges [0] < $ranges [1];
- if ($need_update) {
-
-
- my @command = (
- qw/svn log --xml -v/, ($stop_on_copy ? '--stop-on-copy' : ()),
- '-r' . join (':', @ranges),
- $self->url_peg,
- );
- my $rc;
- my @xml = &run_command (
- \@command,
- PRINT => $self->config->verbose > 2,
- METHOD => 'qx',
- DEVNULL => 1,
- ERROR => 'ignore',
- RC => \$rc,
- );
-
-
- if (not $rc) {
- my $parser = XML::DOM::Parser->new;
- my $doc = $parser->parse (join ('', @xml));
- my $entry_list = $doc->getElementsByTagName ('logentry');
-
- for my $i (0 .. $entry_list->getLength - 1) {
-
- my $entry = $entry_list->item ($i);
- my %this = ();
-
- my $rev = $entry->getAttributeNode ('revision')->getValue;
-
- for my $key (qw/author date msg/) {
-
- my $node = $entry->getElementsByTagName ($key)->item (0);
- my $data = ($node and $node->getFirstChild)
- ? $node->getFirstChild->getData : '';
- $this{$key} = ($key eq 'date' ? str2time ($data) : $data);
- }
-
- my $paths = $entry->getElementsByTagName ('path');
- for my $p (0 .. $paths->getLength - 1) {
-
- my $node = $paths->item ($p);
-
- my $path = $node->getFirstChild->getData;
- $this{paths}{$path} = {};
-
- for my $key (qw/action copyfrom-path copyfrom-rev/) {
- next unless $node->getAttributeNode ($key);
- $this{paths}{$path}{$key} = $node->getAttributeNode ($key)->getValue;
- }
- }
- $self->{LOG}{$rev} = \%this;
- }
- }
-
-
-
- $self->{LOG_RANGE}{UPPER} = $ranges [0]
- if ! $self->{LOG_RANGE}{UPPER} or $ranges [0] > $self->{LOG_RANGE}{UPPER};
-
- if ($stop_on_copy) {
-
- $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1]
- if ! $self->{LOG_RANGE}{LOWER_SOC} or
- $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC};
- my $low = (sort {$a <=> $b} keys %{ $self->{LOG} }) [0];
- $self->{LOG_RANGE}{LOWER} = $low
- if ! $self->{LOG_RANGE}{LOWER} or $low < $self->{LOG_RANGE}{LOWER};
- } else {
-
- $self->{LOG_RANGE}{LOWER} = $ranges [1]
- if ! $self->{LOG_RANGE}{LOWER} or
- $ranges [1] < $self->{LOG_RANGE}{LOWER};
- $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1]
- if ! $self->{LOG_RANGE}{LOWER_SOC} or
- $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC};
- }
- }
- my %return = ();
- if (! $rev_arg or ref ($rev_arg)) {
-
- for my $rev (sort {$b <=> $a} keys %{ $self->{LOG} }) {
- next if $rev > $revs [0] or $revs [1] > $rev;
- $return{$rev} = $self->{LOG}{$rev};
- if ($stop_on_copy) {
- last if exists $self->{LOG}{$rev}{paths}{$self->branch_path} and
- $self->{LOG}{$rev}{paths}{$self->branch_path}{action} eq 'A';
- }
- }
- } else {
-
- %return = %{ $self->{LOG}{$revs [0]} } if exists $self->{LOG}{$revs [0]};
- }
- return %return;
- }
- sub display_svnlog {
- my ($self, $rev, $wiki) = @_;
- my $return = '';
- my %log = $self->svnlog (REV => $rev);
- if ($wiki) {
-
-
- $return .= '|| ' . &svn_date ($log{date}) . ' || ' . $log{author} . ' || ';
- my $trac_url = Fcm::Keyword::get_browser_url($self->url);
-
- my @tickets;
- while ($log{msg} =~ /(?:(\w+):)?(?:#|ticket:)(\d+)/g) {
- push @tickets, [$1, $2];
- }
- @tickets = sort {
- if ($a->[0] and $b->[0]) {
- $a->[0] cmp $b->[0] or $a->[1] <=> $b->[1];
- } elsif ($a->[0]) {
- 1;
- } else {
- $a->[1] <=> $b->[1];
- }
- } @tickets;
- if ($trac_url =~ m
-
- $return .= '[' . $rev . '] ||';
- for my $ticket (@tickets) {
- $return .= ' ';
- $return .= $ticket->[0] . ':' if $ticket->[0];
- $return .= '#' . $ticket->[1];
- }
- $return .= ' ||';
- } else {
-
- my $rev_url = $trac_url;
- $rev_url =~ s{/intertrac/source:.*\z}{/intertrac/changeset:$rev}xms;
- $return .= '[' . $rev_url . ' ' . $rev . '] ||';
- my $ticket_url = $trac_url;
- $ticket_url =~ s{/intertrac/source:.*\z}{/intertrac/}xms;
- for my $ticket (@tickets) {
- $return .= ' [' . $ticket_url;
- $return .= $ticket->[0] . ':' if $ticket->[0];
- $return .= 'ticket:' . $ticket->[1] . ' ' . $ticket->[1] . ']';
- }
- $return .= ' ||';
- }
- } else {
-
-
- my @msg = split /\n/, $log{msg};
- my $line = (@msg > 1 ? ' lines' : ' line');
- $return .= join (
- ' | ',
- ('r' . $rev, $log{author}, &svn_date ($log{date}), scalar (@msg) . $line),
- );
- $return .= "\n\n";
- $return .= $log{msg};
- }
- return $return;
- }
- sub svnlist {
- my $self = shift;
- my %args = @_;
- my $recursive = exists $args{RECURSIVE} ? $args{RECURSIVE} : 0;
- my $rev = exists $args{REV} ? $args{REV} : undef;
- my $key = $recursive ? 'RLIST' : 'LIST';
-
- $rev = $self->svninfo (FLAG => 'Last Changed Rev', REV => $rev);
- return () if not $rev;
-
- if (not exists $self->{$key}{$rev}) {
- my $rc;
- my @list = map {chomp; $_} &run_command (
- [qw/svn list -r/, $rev, ($recursive ? '-R' : ()), $self->url_peg],
- METHOD => 'qx', ERROR => 'ignore', DEVNULL => 1, RC => \$rc,
- );
- $self->{$key}{$rev} = $rc ? undef : \@list;
- }
- return (defined ($self->{$key}{$rev}) ? @{ $self->{$key}{$rev} } : undef);
- }
- sub branch_list {
- my ($self, $rev) = @_;
-
- return if not $self->project;
-
- $rev = $self->svninfo (FLAG => 'Revision', REV => $rev);
- return () if not $rev;
- if (not exists $self->{BRANCH_LIST}{$rev}) {
- $self->{BRANCH_LIST}{$rev} = [];
-
- my $url = Fcm::CmUrl->new (URL => $self->project_url . '/branches');
-
-
- my @list1 = map {$url->url . '/' . $_} $url->svnlist (REV => $rev);
- @list1 = grep m
-
- my @list2;
- for (@list1) {
- my $u = Fcm::CmUrl->new (URL => $_);
- my @list = $u->svnlist (REV => $rev);
- push @list2, map {$u->url . $_} @list;
- }
-
- for (@list2) {
- my $u = Fcm::CmUrl->new (URL => $_);
- my @list = map {s
- push @{ $self->{BRANCH_LIST}{$rev} }, map {$u->url . $_} @list;
- }
- }
- return @{ $self->{BRANCH_LIST}{$rev} };
- }
- sub _analyse_url {
- my $self = shift;
- my ($url, $project, $branch, $subdir, $pegrev);
-
- $url = $self->url_peg;
- return if not $url;
- return if not $self->is_url;
-
- $pegrev = $1 if $url =~ s/@($rev_pattern)$//i;
- if ($url =~ m
-
- $project = $1;
- my ($branch_id, $remain) = ($2, $3);
- $remain = '' if not defined $remain;
- if ($branch_id eq 'trunk') {
-
- $branch = 'trunk';
- } else {
-
- $branch = $branch_id;
-
- for (1 .. 3) {
- if ($remain =~ s
- $branch .= '/' . $1;
- } else {
- $branch = undef;
- last;
- }
- }
- }
- $subdir = $remain ? $remain : '' if $branch;
- } else {
-
-
- my @list = $self->svnlist (REV => ($pegrev ? $pegrev : 'HEAD'));
- my %lines = map {chomp $_; ($_, 1)} @list;
-
- ($project = $url) =~ s
- if $lines{'trunk/'} and $lines{'branches/'} and $lines{'tags/'};
- }
- $self->{PROJECT} = $project;
- $self->{BRANCH} = $branch;
- $self->{SUBDIR} = $subdir;
- $self->{PEGREV} = $pegrev;
- $self->{ANALYSED} = 1;
- return;
- }
- sub root {
- my $self = shift;
- return $self->svninfo (FLAG => 'Repository Root');
- }
- sub project_url_peg {
- my $self = shift;
- if (@_) {
- my $url = shift;
-
- if (! $self->project_url_peg or $url ne $self->project_url_peg) {
- my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : '';
- $url .= '/' . $self->branch if $self->branch;
- $url .= '/' . $self->subdir if $self->subdir;
- $url .= '@' . $pegrev if $pegrev;
- $self->url_peg ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return $self->{PROJECT} . ($self->pegrev ? '@' . $self->pegrev : '');
- }
- sub project_url {
- my $self = shift;
- if (@_) {
- my $url = shift;
- $url =~ s/@($rev_pattern)$//i;
-
- if (! $self->project_url or $url ne $self->project_url) {
- $url .= '/' . $self->branch if $self->branch;
- $url .= '/' . $self->subdir if $self->subdir;
- $self->url ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return $self->{PROJECT};
- }
- sub project_path {
- my $self = shift;
-
- my $root = $self->root;
- $root = substr (
- $self->project_url,
- 0,
- length ($self->project_url) - length ($self->project) - 1
- ) if not $root;
- if (@_) {
- my $path = shift;
-
- if (! $self->project_path or $path ne $self->project_path) {
- $path .= '/' . $self->branch if $self->branch;
- $path .= '/' . $self->subdir if $self->subdir;
- $self->path ($path);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return substr ($self->{PROJECT}, length ($root));
- }
- sub project {
- my $self = shift;
- if (@_) {
- my $name = shift;
-
- if (! $self->project or $name ne $self->project) {
- my $url = '';
- if ($self->project) {
- $url = $self->project;
- $url =~ s
- } else {
- $url = $self->root;
- }
- $url .= '/' . $name;
- $url .= '/' . $self->branch if $self->branch;
- $url .= '/' . $self->subdir if $self->subdir;
- $url .= '@' . $self->pegrev if $self->pegrev;
- $self->url_peg ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- my $name = $self->{PROJECT};
- $name =~ s
- return $name;
- }
- sub branch_url_peg {
- my $self = shift;
- if (@_) {
- my $url = shift;
-
- if (! $self->branch_url_peg or $url ne $self->branch_url_peg) {
- my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : '';
- $url .= '/' . $self->subdir if $self->subdir;
- $url .= '@' . $pegrev if $pegrev;
- $self->url_peg ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return $self->project_url . '/' . $self->branch .
- ($self->pegrev ? '@' . $self->pegrev : '');
- }
- sub branch_url {
- my $self = shift;
- if (@_) {
- my $url = shift;
- $url =~ s/@($rev_pattern)$//i;
-
- if (! $self->branch_url or $url ne $self->branch_url) {
- $url .= '/' . $self->subdir if $self->subdir;
- $self->url ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return $self->project_url . '/' . $self->branch;
- }
- sub branch_path {
- my $self = shift;
- if (@_) {
- my $path = shift;
-
- if (! $self->branch_path or $path ne $self->branch_path) {
- $path .= '/' . $self->subdir if $self->subdir;
- $self->path ($path);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return ($self->branch ? $self->project_path . '/' . $self->branch : undef);
- }
- sub branch {
- my $self = shift;
- if (@_) {
- my $branch = shift;
-
- if (! $self->branch or $branch ne $self->branch) {
- my $url = $self->project_url;
- $url .= '/' . $branch;
- $url .= '/' . $self->subdir if $self->subdir;
- $self->url ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return $self->{BRANCH};
- }
- sub branch_owner {
- my $self = shift;
- my $return;
- if ($self->is_branch and $self->branch_url =~ m
- my $user = $1;
- $return = $user;
- }
- return $return;
- }
- sub is_trunk {
- my $self = shift;
- $self->_analyse_url () if not $self->{ANALYSED};
- return ($self->branch and $self->branch eq 'trunk');
- }
- sub is_branch {
- my $self = shift;
- $self->_analyse_url () if not $self->{ANALYSED};
- return ($self->branch and $self->branch =~ m
- }
- sub is_tag {
- my $self = shift;
- $self->_analyse_url () if not $self->{ANALYSED};
- return ($self->branch and $self->branch =~ m
- }
- sub subdir {
- my $self = shift;
- if (@_) {
- my $subdir = shift;
-
- if (! $self->subdir or $subdir ne $self->subdir) {
- my $url = $self->project_url;
- $url .= '/' . $self->branch if $self->branch;
- $url .= '/' . $subdir if $subdir;
- $self->url ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return $self->{SUBDIR};
- }
- sub url {
- my $self = shift;
- if (@_) {
- my $url = shift;
- $url =~ s/@($rev_pattern)$//i;
-
- if (! $self->url or $url ne $self->url) {
- $self->url_peg ($url . ($self->pegrev ? '@' . $self->pegrev : ''));
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- (my $url = $self->url_peg) =~ s/@($rev_pattern)$//i;
- return $url;
- }
- sub path {
- my $self = shift;
-
- my $root = $self->root;
- $root = substr (
- $self->project_url,
- 0,
- length ($self->project_url) - length ($self->project) - 1
- ) if not $root;
- if (@_) {
- my $path = shift;
- $path =~ s/@($rev_pattern)$//i;
-
- if (! $self->path or $path ne $self->path) {
- my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path);
- $self->url ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return substr ($self->url, length ($root));
- }
- sub path_peg {
- my $self = shift;
-
- my $root = $self->root;
- $root = substr (
- $self->project_url,
- 0,
- length ($self->project_url) - length ($self->project) - 1
- ) if not $root;
- if (@_) {
- my $path = shift;
-
- if (! $self->path_peg or $path ne $self->path_peg) {
- my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path);
- $self->url_peg ($url);
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return substr ($self->url_peg, length ($root));
- }
- sub pegrev {
- my $self = shift;
- if (@_) {
- my $pegrev = shift;
-
- if (! $self->pegrev or $pegrev ne $self->pegrev) {
- $self->url_peg ($self->url . ($pegrev ? '@' . $pegrev : ''));
- }
- }
- $self->_analyse_url () if not $self->{ANALYSED};
- return $self->{PEGREV};
- }
- 1;
- __END__
|